FBXIP165 ;OIPD/SAB - PATCH INSTALL ROUTINE ;12/28/2015
;;3.5;FEE BASIS;**165**;JAN 30, 1995;Build 7
;;Per VA Directive 6402, this routine should not be modified.
;
; ICRs
; #2053 FILE^DIE
; #2056 $$GET1^DIQ
; #10103 $$FMADD^XLFDT, $$FMTE^XLFDT
; #10141 BMES^XPDUTL, MES^XPDUTL, $$NEWCP^XPDUTL
;
PS ; post-install entry point
; create KIDS checkpoints with call backs
N FBX,Y
F FBX="DELREJ","RMVPAY" D
. S Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP165")
. I 'Y D BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")
Q
;
RMVPAY ; remove payments that are paid or cancelled from in-process batch
G IN^FBXI165A
Q
;
DELREJ ; delete inappropriate reject flags from old payments
N DA,DIERR,FBBAT,FBC,FBCKNUM,FBDT132,FBDTC,FBDTF,FBDTP
N FBFILE,FBIENS,FBX
D BMES^XPDUTL(" Deleting inappropriate reject flags on payments. This may take some time.")
;
;
S FBDT132=3130307 ; patch FB*3.5*132 compliance date
;
; set header for XTMP with purge date in 180 days
S ^XTMP("FB*3.5*165",0)=$$FMADD^XLFDT(DT,180)_"^"_DT_"^From patch FB*3.5*165 post init."
;
D MES^XPDUTL(" processing sub-file 162.03...")
D INITCNT
S FBFILE=162.03
; loop thru rejected payments using x-ref on OLD BATCH NUMBER
; loop thru old batch number
S FBBAT=0 F S FBBAT=$O(^FBAAC("AH",FBBAT)) Q:'FBBAT D
. ; loop thru patient
. N DA
. S DA(3)=0 F S DA(3)=$O(^FBAAC("AH",FBBAT,DA(3))) Q:'DA(3) D
. . ; loop thru vendor
. . S DA(2)=0 F S DA(2)=$O(^FBAAC("AH",FBBAT,DA(3),DA(2))) Q:'DA(2) D
. . . ; loop thru initial treatment date
. . . S DA(1)=0
. . . F S DA(1)=$O(^FBAAC("AH",FBBAT,DA(3),DA(2),DA(1))) Q:'DA(1) D
. . . . ; loop thru service provided
. . . . S DA=0
. . . . F S DA=$O(^FBAAC("AH",FBBAT,DA(3),DA(2),DA(1),DA)) Q:'DA D
. . . . . S FBDTP=$P($G(^FBAAC(DA(3),1,DA(2),1,DA(1),1,DA,0)),U,14) ; paid
. . . . . S FBDTC=$P($G(^FBAAC(DA(3),1,DA(2),1,DA(1),1,DA,2)),U,4) ; canc
. . . . . S FBCKNUM=$P($G(^FBAAC(DA(3),1,DA(2),1,DA(1),1,DA,2)),U,3)
. . . . . Q:'$$OKDEL
. . . . . ;
. . . . . S FBIENS=DA_","_DA(1)_","_DA(2)_","_DA(3)_","
. . . . . ;
. . . . . ; save current reject data to XTMP
. . . . . M ^XTMP("FB*3.5*165","DELREJ",FBFILE,FBBAT,FBIENS,"FBREJ")=^FBAAC(DA(3),1,DA(2),1,DA(1),1,DA,"FBREJ")
. . . . . M ^XTMP("FB*3.5*165","DELREJ",FBFILE,FBBAT,FBIENS,"FBREJC")=^FBAAC(DA(3),1,DA(2),1,DA(1),1,DA,"FBREJC")
. . . . . ;
. . . . . ; delete reject flag
. . . . . S FBX=$$DELREJ^FBAARR3(FBFILE,FBIENS)
. . . . . I 'FBX D MES^XPDUTL(" Problem encountered while deleting reject flag for record with IENS "_FBIENS)
. . . . . I 'FBX,$P(FBX,U,2)'="" D MES^XPDUTL(" "_$P(FBX,U,2))
. . . . . ;
. . . . . ; populate payment date finalized using value from batch
. . . . . I FBDTF?7N D
. . . . . . N FBFDA,DIERR
. . . . . . S FBFDA(162.03,FBIENS,5)=FBDTF
. . . . . . D FILE^DIE("","FBFDA")
. . . . . . I $G(DIERR)'="" D MES^XPDUTL(" Error updating date finalized for record with IENS "_FBIENS)
D SHOWCNT
;
D MES^XPDUTL(" processing file 162.5...")
D INITCNT
S FBFILE=162.5
; loop thru rejected payments using x-ref on OLD BATCH NUMBER
; loop thru old batch number
S FBBAT=0 F S FBBAT=$O(^FBAAI("AH",FBBAT)) Q:'FBBAT D
. ; loop thru invoice
. N DA
. S DA=0 F S DA=$O(^FBAAI("AH",FBBAT,DA)) Q:'DA D
. . S FBDTP=$P($G(^FBAAI(DA,2)),U,1) ; paid
. . S FBDTC=$P($G(^FBAAI(DA,2)),U,5) ; canc
. . Q:'$$OKDEL
. . ;
. . S FBIENS=DA_","
. . ;
. . ; save current reject data to XTMP
. . M ^XTMP("FB*3.5*165","DELREJ",FBFILE,FBBAT,FBIENS,"FBREJ")=^FBAAI(DA,"FBREJ")
. . M ^XTMP("FB*3.5*165","DELREJ",FBFILE,FBBAT,FBIENS,"FBREJC")=^FBAAI(DA,"FBREJC")
. . ;
. . ; delete reject flag
. . S FBX=$$DELREJ^FBAARR3(FBFILE,FBIENS)
. . I 'FBX D MES^XPDUTL(" Problem encountered while deleting reject flag for record with IENS "_FBIENS)
. . I 'FBX,$P(FBX,U,2)'="" D MES^XPDUTL(" "_$P(FBX,U,2))
. . ;
. . ; populate payment date finalized using value from batch
. . I FBDTF?7N D
. . . N FBFDA,DIERR
. . . S FBFDA(162.5,FBIENS,19)=FBDTF
. . . D FILE^DIE("","FBFDA")
. . . I $G(DIERR)'="" D MES^XPDUTL(" Error updating date finalized for record with IENS "_FBIENS)
D SHOWCNT
;
D MES^XPDUTL(" processing sub-file 162.04...")
D INITCNT
S FBFILE=162.04
; loop thru rejected payments using x-ref on OLD BATCH NUMBER
; loop thru old batch number
S FBBAT=0 F S FBBAT=$O(^FBAAC("AG",FBBAT)) Q:'FBBAT D
. ; loop thru patient
. N DA
. S DA(1)=0 F S DA(1)=$O(^FBAAC("AG",FBBAT,DA(1))) Q:'DA(1) D
. . ; loop thru travel payment date
. . S DA=0 F S DA=$O(^FBAAC("AG",FBBAT,DA(1),DA)) Q:'DA D
. . . S FBDTP=$P($G(^FBAAC(DA(1),3,DA,0)),U,6) ; paid
. . . S FBDTC=$P($G(^FBAAC(DA(1),3,DA,0)),U,8) ; canc
. . . Q:'$$OKDEL
. . . ;
. . . S FBIENS=DA_","_DA(1)_","
. . . ;
. . . ; save current reject data to XTMP
. . . M ^XTMP("FB*3.5*165","DELREJ",FBFILE,FBBAT,FBIENS,"FBREJ")=^FBAAC(DA(1),3,DA,"FBREJ")
. . . M ^XTMP("FB*3.5*165","DELREJ",FBFILE,FBBAT,FBIENS,"FBREJC")=^FBAAC(DA(1),3,DA,"FBREJC")
. . . ;
. . . ; delete reject flag
. . . S FBX=$$DELREJ^FBAARR3(FBFILE,FBIENS)
. . . I 'FBX D MES^XPDUTL(" Problem encountered while deleting reject flag for record with IENS "_FBIENS)
. . . I 'FBX,$P(FBX,U,2)'="" D MES^XPDUTL(" "_$P(FBX,U,2))
D SHOWCNT
;
D MES^XPDUTL(" processing sub-file 162.11...")
D INITCNT
S FBFILE=162.11
; loop thru rejected payments using x-ref on OLD BATCH NUMBER
; loop thru old batch number
S FBBAT=0 F S FBBAT=$O(^FBAA(162.1,"AF",FBBAT)) Q:'FBBAT D
. ; loop thru invoice
. N DA
. S DA(1)=0 F S DA(1)=$O(^FBAA(162.1,"AF",FBBAT,DA(1))) Q:'DA(1) D
. . ; loop thru prescription
. . S DA=0 F S DA=$O(^FBAA(162.1,"AF",FBBAT,DA(1),DA)) Q:'DA D
. . . S FBDTP=$P($G(^FBAA(162.1,DA(1),"RX",DA,2)),U,8) ; paid
. . . S FBDTC=$P($G(^FBAA(162.1,DA(1),"RX",DA,2)),U,11) ; canc
. . . Q:'$$OKDEL
. . . ;
. . . S FBIENS=DA_","_DA(1)_","
. . . ;
. . . ; save current reject data to XTMP
. . . M ^XTMP("FB*3.5*165","DELREJ",FBFILE,FBBAT,FBIENS,"FBREJ")=^FBAA(162.1,DA(1),"RX",DA,"FBREJ")
. . . M ^XTMP("FB*3.5*165","DELREJ",FBFILE,FBBAT,FBIENS,"FBREJC")=^FBAA(162.1,DA(1),"RX",DA,"FBREJC")
. . . ;
. . . ; delete reject flag
. . . S FBX=$$DELREJ^FBAARR3(FBFILE,FBIENS)
. . . I 'FBX D MES^XPDUTL(" Problem encountered while deleting reject flag for record with IENS "_FBIENS)
. . . I 'FBX,$P(FBX,U,2)'="" D MES^XPDUTL(" "_$P(FBX,U,2))
D SHOWCNT
;
D MES^XPDUTL(" Done deleting inappropriate reject flags.")
Q
OKDEL() ; check reject for inappropriate reject flag
; Input
; FBDT132 - compiance date for FB*3.5*132
; FBDTP - DATE PAID
; FBDTC - CANCELLATION DATE
; FBBAT - OLD BATCH NUMBER
; FBC( - counters
; FBFILE - file or sub-file number
; FBCKNUM - FBCKNUM only defined when FBFILE = 162.03
; Output
; FBDTF - DATE FINALIZED for batch FBBAT
; FBC( - counters
; Return value
; 0 or 1, true (=1) if reject flag should be deleted
;
N FBOLD
;
; increment count of rejects
S FBC("REJ")=FBC("REJ")+1
;
; Skip if line item not confirmed or cancelled
I 'FBDTP,'FBDTC Q 0
; if outp/anc, not cancelled, date paid exists but < 1/1/2011 and
; check number is blank then don't treat as a confirmed payment.
; Prior to version 3.5 the DATE PAID was populated by transmission
; to Central FEE instead of a value returned by Central FEE.
; CHECK NUMBER is better indicator of actual payment except for
; 0 dollar line items which were not transmitted to Central FEE until
; patch FB*3.5*116. Earliest install of FB*3.5*116 is Jan 7, 2011.
I FBFILE=162.03,'FBDTC,FBDTP,FBDTP<3110107,FBCKNUM="" Q 0
;
; increment count of rejects with payment confirmation/cancellation
S FBC("REJC")=FBC("REJC")+1
;
; don't delete if batch status is not vouchered
I $S(FBBAT:$$GET1^DIQ(161.7,FBBAT_",",11,"I"),1:"")'="V" D Q 0
. S FBC("NVOU")=FBC("NVOU")+1
;
; determine if is an old payment
S FBOLD=0
S FBDTF=$S(FBBAT:$$GET1^DIQ(161.7,FBBAT_",",13,"I"),1:"") ; finalized
I FBDTF,FBDTF<FBDT132 S FBOLD=1
I 'FBOLD,FBDTP,FBDTP<FBDT132 S FBOLD=1
I 'FBOLD,FBDTC,FBDTC<FBDT132 S FBOLD=1
; don't delete if not an old payment
I 'FBOLD S FBC("NOLD")=FBC("NOLD")+1 Q 0
;
; passed all checks to delete the reject flag
S FBC("DELR")=FBC("DELR")+1
Q 1
;
INITCNT ; initalize counters for file/sub-file
S FBC("REJ")=0 ; count of line items flagged as rejected
S FBC("REJC")=0 ; count of rejected line items with pay conf/canc
S FBC("NVOU")=0 ; count of inapp. rejects not vouchered so not deleted
S FBC("NOLD")=0 ; count of inapp. rejects not old so not deleted
S FBC("DELR")=0 ; count of reject flags deleted
Q
SHOWCNT ; show counts for file/sub-file
N FBTYPE,FBX
I FBFILE=162.03 S FBTYPE="outpatient/ancillary"
I FBFILE=162.04 S FBTYPE="travel"
I FBFILE=162.11 S FBTYPE="pharmacy"
I FBFILE=162.5 S FBTYPE="inpatient"
S FBX=$J($FN(FBC("REJ"),","),10)_" "_FBTYPE_" payment lines were flagged as rejected."
D MES^XPDUTL(FBX)
S FBX=$J($FN(FBC("REJC"),","),10)_" of these rejects are inappropriate because the payment line"
D MES^XPDUTL(FBX)
S FBX=" also has payment confirmation or payment cancellation data."
D MES^XPDUTL(FBX)
S FBX=$J($FN(FBC("DELR"),","),10)_" of the inappropriate reject flags were deleted."
D MES^XPDUTL(FBX)
I FBC("NVOU")>0 D
. S FBX=$J($FN(FBC("NVOU"),","),10)_" of the inappropriate reject flags could not be deleted"
. D MES^XPDUTL(FBX)
. S FBX=" because the batch status is not vouchered."
. D MES^XPDUTL(FBX)
I FBC("NOLD")>0 D
. S FBX=$J($FN(FBC("NOLD"),","),10)_" of the inappropriate reject flags could not be deleted"
. D MES^XPDUTL(FBX)
. S FBX=" because the payment is not prior to "_$$FMTE^XLFDT(FBDT132)_"."
. D MES^XPDUTL(FBX)
Q
;
;FBXIP165
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBXIP165 9980 printed Nov 22, 2024@17:11:34 Page 2
FBXIP165 ;OIPD/SAB - PATCH INSTALL ROUTINE ;12/28/2015
+1 ;;3.5;FEE BASIS;**165**;JAN 30, 1995;Build 7
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; ICRs
+5 ; #2053 FILE^DIE
+6 ; #2056 $$GET1^DIQ
+7 ; #10103 $$FMADD^XLFDT, $$FMTE^XLFDT
+8 ; #10141 BMES^XPDUTL, MES^XPDUTL, $$NEWCP^XPDUTL
+9 ;
PS ; post-install entry point
+1 ; create KIDS checkpoints with call backs
+2 NEW FBX,Y
+3 FOR FBX="DELREJ","RMVPAY"
Begin DoDot:1
+4 SET Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP165")
+5 IF 'Y
DO BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")
End DoDot:1
+6 QUIT
+7 ;
RMVPAY ; remove payments that are paid or cancelled from in-process batch
+1 GOTO IN^FBXI165A
+2 QUIT
+3 ;
DELREJ ; delete inappropriate reject flags from old payments
+1 NEW DA,DIERR,FBBAT,FBC,FBCKNUM,FBDT132,FBDTC,FBDTF,FBDTP
+2 NEW FBFILE,FBIENS,FBX
+3 DO BMES^XPDUTL(" Deleting inappropriate reject flags on payments. This may take some time.")
+4 ;
+5 ;
+6 ; patch FB*3.5*132 compliance date
SET FBDT132=3130307
+7 ;
+8 ; set header for XTMP with purge date in 180 days
+9 SET ^XTMP("FB*3.5*165",0)=$$FMADD^XLFDT(DT,180)_"^"_DT_"^From patch FB*3.5*165 post init."
+10 ;
+11 DO MES^XPDUTL(" processing sub-file 162.03...")
+12 DO INITCNT
+13 SET FBFILE=162.03
+14 ; loop thru rejected payments using x-ref on OLD BATCH NUMBER
+15 ; loop thru old batch number
+16 SET FBBAT=0
FOR
SET FBBAT=$ORDER(^FBAAC("AH",FBBAT))
if 'FBBAT
QUIT
Begin DoDot:1
+17 ; loop thru patient
+18 NEW DA
+19 SET DA(3)=0
FOR
SET DA(3)=$ORDER(^FBAAC("AH",FBBAT,DA(3)))
if 'DA(3)
QUIT
Begin DoDot:2
+20 ; loop thru vendor
+21 SET DA(2)=0
FOR
SET DA(2)=$ORDER(^FBAAC("AH",FBBAT,DA(3),DA(2)))
if 'DA(2)
QUIT
Begin DoDot:3
+22 ; loop thru initial treatment date
+23 SET DA(1)=0
+24 FOR
SET DA(1)=$ORDER(^FBAAC("AH",FBBAT,DA(3),DA(2),DA(1)))
if 'DA(1)
QUIT
Begin DoDot:4
+25 ; loop thru service provided
+26 SET DA=0
+27 FOR
SET DA=$ORDER(^FBAAC("AH",FBBAT,DA(3),DA(2),DA(1),DA))
if 'DA
QUIT
Begin DoDot:5
+28 ; paid
SET FBDTP=$PIECE($GET(^FBAAC(DA(3),1,DA(2),1,DA(1),1,DA,0)),U,14)
+29 ; canc
SET FBDTC=$PIECE($GET(^FBAAC(DA(3),1,DA(2),1,DA(1),1,DA,2)),U,4)
+30 SET FBCKNUM=$PIECE($GET(^FBAAC(DA(3),1,DA(2),1,DA(1),1,DA,2)),U,3)
+31 if '$$OKDEL
QUIT
+32 ;
+33 SET FBIENS=DA_","_DA(1)_","_DA(2)_","_DA(3)_","
+34 ;
+35 ; save current reject data to XTMP
+36 MERGE ^XTMP("FB*3.5*165","DELREJ",FBFILE,FBBAT,FBIENS,"FBREJ")=^FBAAC(DA(3),1,DA(2),1,DA(1),1,DA,"FBREJ")
+37 MERGE ^XTMP("FB*3.5*165","DELREJ",FBFILE,FBBAT,FBIENS,"FBREJC")=^FBAAC(DA(3),1,DA(2),1,DA(1),1,DA,"FBREJC")
+38 ;
+39 ; delete reject flag
+40 SET FBX=$$DELREJ^FBAARR3(FBFILE,FBIENS)
+41 IF 'FBX
DO MES^XPDUTL(" Problem encountered while deleting reject flag for record with IENS "_FBIENS)
+42 IF 'FBX
IF $PIECE(FBX,U,2)'=""
DO MES^XPDUTL(" "_$PIECE(FBX,U,2))
+43 ;
+44 ; populate payment date finalized using value from batch
+45 IF FBDTF?7N
Begin DoDot:6
+46 NEW FBFDA,DIERR
+47 SET FBFDA(162.03,FBIENS,5)=FBDTF
+48 DO FILE^DIE("","FBFDA")
+49 IF $GET(DIERR)'=""
DO MES^XPDUTL(" Error updating date finalized for record with IENS "_FBIENS)
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+50 DO SHOWCNT
+51 ;
+52 DO MES^XPDUTL(" processing file 162.5...")
+53 DO INITCNT
+54 SET FBFILE=162.5
+55 ; loop thru rejected payments using x-ref on OLD BATCH NUMBER
+56 ; loop thru old batch number
+57 SET FBBAT=0
FOR
SET FBBAT=$ORDER(^FBAAI("AH",FBBAT))
if 'FBBAT
QUIT
Begin DoDot:1
+58 ; loop thru invoice
+59 NEW DA
+60 SET DA=0
FOR
SET DA=$ORDER(^FBAAI("AH",FBBAT,DA))
if 'DA
QUIT
Begin DoDot:2
+61 ; paid
SET FBDTP=$PIECE($GET(^FBAAI(DA,2)),U,1)
+62 ; canc
SET FBDTC=$PIECE($GET(^FBAAI(DA,2)),U,5)
+63 if '$$OKDEL
QUIT
+64 ;
+65 SET FBIENS=DA_","
+66 ;
+67 ; save current reject data to XTMP
+68 MERGE ^XTMP("FB*3.5*165","DELREJ",FBFILE,FBBAT,FBIENS,"FBREJ")=^FBAAI(DA,"FBREJ")
+69 MERGE ^XTMP("FB*3.5*165","DELREJ",FBFILE,FBBAT,FBIENS,"FBREJC")=^FBAAI(DA,"FBREJC")
+70 ;
+71 ; delete reject flag
+72 SET FBX=$$DELREJ^FBAARR3(FBFILE,FBIENS)
+73 IF 'FBX
DO MES^XPDUTL(" Problem encountered while deleting reject flag for record with IENS "_FBIENS)
+74 IF 'FBX
IF $PIECE(FBX,U,2)'=""
DO MES^XPDUTL(" "_$PIECE(FBX,U,2))
+75 ;
+76 ; populate payment date finalized using value from batch
+77 IF FBDTF?7N
Begin DoDot:3
+78 NEW FBFDA,DIERR
+79 SET FBFDA(162.5,FBIENS,19)=FBDTF
+80 DO FILE^DIE("","FBFDA")
+81 IF $GET(DIERR)'=""
DO MES^XPDUTL(" Error updating date finalized for record with IENS "_FBIENS)
End DoDot:3
End DoDot:2
End DoDot:1
+82 DO SHOWCNT
+83 ;
+84 DO MES^XPDUTL(" processing sub-file 162.04...")
+85 DO INITCNT
+86 SET FBFILE=162.04
+87 ; loop thru rejected payments using x-ref on OLD BATCH NUMBER
+88 ; loop thru old batch number
+89 SET FBBAT=0
FOR
SET FBBAT=$ORDER(^FBAAC("AG",FBBAT))
if 'FBBAT
QUIT
Begin DoDot:1
+90 ; loop thru patient
+91 NEW DA
+92 SET DA(1)=0
FOR
SET DA(1)=$ORDER(^FBAAC("AG",FBBAT,DA(1)))
if 'DA(1)
QUIT
Begin DoDot:2
+93 ; loop thru travel payment date
+94 SET DA=0
FOR
SET DA=$ORDER(^FBAAC("AG",FBBAT,DA(1),DA))
if 'DA
QUIT
Begin DoDot:3
+95 ; paid
SET FBDTP=$PIECE($GET(^FBAAC(DA(1),3,DA,0)),U,6)
+96 ; canc
SET FBDTC=$PIECE($GET(^FBAAC(DA(1),3,DA,0)),U,8)
+97 if '$$OKDEL
QUIT
+98 ;
+99 SET FBIENS=DA_","_DA(1)_","
+100 ;
+101 ; save current reject data to XTMP
+102 MERGE ^XTMP("FB*3.5*165","DELREJ",FBFILE,FBBAT,FBIENS,"FBREJ")=^FBAAC(DA(1),3,DA,"FBREJ")
+103 MERGE ^XTMP("FB*3.5*165","DELREJ",FBFILE,FBBAT,FBIENS,"FBREJC")=^FBAAC(DA(1),3,DA,"FBREJC")
+104 ;
+105 ; delete reject flag
+106 SET FBX=$$DELREJ^FBAARR3(FBFILE,FBIENS)
+107 IF 'FBX
DO MES^XPDUTL(" Problem encountered while deleting reject flag for record with IENS "_FBIENS)
+108 IF 'FBX
IF $PIECE(FBX,U,2)'=""
DO MES^XPDUTL(" "_$PIECE(FBX,U,2))
End DoDot:3
End DoDot:2
End DoDot:1
+109 DO SHOWCNT
+110 ;
+111 DO MES^XPDUTL(" processing sub-file 162.11...")
+112 DO INITCNT
+113 SET FBFILE=162.11
+114 ; loop thru rejected payments using x-ref on OLD BATCH NUMBER
+115 ; loop thru old batch number
+116 SET FBBAT=0
FOR
SET FBBAT=$ORDER(^FBAA(162.1,"AF",FBBAT))
if 'FBBAT
QUIT
Begin DoDot:1
+117 ; loop thru invoice
+118 NEW DA
+119 SET DA(1)=0
FOR
SET DA(1)=$ORDER(^FBAA(162.1,"AF",FBBAT,DA(1)))
if 'DA(1)
QUIT
Begin DoDot:2
+120 ; loop thru prescription
+121 SET DA=0
FOR
SET DA=$ORDER(^FBAA(162.1,"AF",FBBAT,DA(1),DA))
if 'DA
QUIT
Begin DoDot:3
+122 ; paid
SET FBDTP=$PIECE($GET(^FBAA(162.1,DA(1),"RX",DA,2)),U,8)
+123 ; canc
SET FBDTC=$PIECE($GET(^FBAA(162.1,DA(1),"RX",DA,2)),U,11)
+124 if '$$OKDEL
QUIT
+125 ;
+126 SET FBIENS=DA_","_DA(1)_","
+127 ;
+128 ; save current reject data to XTMP
+129 MERGE ^XTMP("FB*3.5*165","DELREJ",FBFILE,FBBAT,FBIENS,"FBREJ")=^FBAA(162.1,DA(1),"RX",DA,"FBREJ")
+130 MERGE ^XTMP("FB*3.5*165","DELREJ",FBFILE,FBBAT,FBIENS,"FBREJC")=^FBAA(162.1,DA(1),"RX",DA,"FBREJC")
+131 ;
+132 ; delete reject flag
+133 SET FBX=$$DELREJ^FBAARR3(FBFILE,FBIENS)
+134 IF 'FBX
DO MES^XPDUTL(" Problem encountered while deleting reject flag for record with IENS "_FBIENS)
+135 IF 'FBX
IF $PIECE(FBX,U,2)'=""
DO MES^XPDUTL(" "_$PIECE(FBX,U,2))
End DoDot:3
End DoDot:2
End DoDot:1
+136 DO SHOWCNT
+137 ;
+138 DO MES^XPDUTL(" Done deleting inappropriate reject flags.")
+139 QUIT
OKDEL() ; check reject for inappropriate reject flag
+1 ; Input
+2 ; FBDT132 - compiance date for FB*3.5*132
+3 ; FBDTP - DATE PAID
+4 ; FBDTC - CANCELLATION DATE
+5 ; FBBAT - OLD BATCH NUMBER
+6 ; FBC( - counters
+7 ; FBFILE - file or sub-file number
+8 ; FBCKNUM - FBCKNUM only defined when FBFILE = 162.03
+9 ; Output
+10 ; FBDTF - DATE FINALIZED for batch FBBAT
+11 ; FBC( - counters
+12 ; Return value
+13 ; 0 or 1, true (=1) if reject flag should be deleted
+14 ;
+15 NEW FBOLD
+16 ;
+17 ; increment count of rejects
+18 SET FBC("REJ")=FBC("REJ")+1
+19 ;
+20 ; Skip if line item not confirmed or cancelled
+21 IF 'FBDTP
IF 'FBDTC
QUIT 0
+22 ; if outp/anc, not cancelled, date paid exists but < 1/1/2011 and
+23 ; check number is blank then don't treat as a confirmed payment.
+24 ; Prior to version 3.5 the DATE PAID was populated by transmission
+25 ; to Central FEE instead of a value returned by Central FEE.
+26 ; CHECK NUMBER is better indicator of actual payment except for
+27 ; 0 dollar line items which were not transmitted to Central FEE until
+28 ; patch FB*3.5*116. Earliest install of FB*3.5*116 is Jan 7, 2011.
+29 IF FBFILE=162.03
IF 'FBDTC
IF FBDTP
IF FBDTP<3110107
IF FBCKNUM=""
QUIT 0
+30 ;
+31 ; increment count of rejects with payment confirmation/cancellation
+32 SET FBC("REJC")=FBC("REJC")+1
+33 ;
+34 ; don't delete if batch status is not vouchered
+35 IF $SELECT(FBBAT:$$GET1^DIQ(161.7,FBBAT_",",11,"I"),1:"")'="V"
Begin DoDot:1
+36 SET FBC("NVOU")=FBC("NVOU")+1
End DoDot:1
QUIT 0
+37 ;
+38 ; determine if is an old payment
+39 SET FBOLD=0
+40 ; finalized
SET FBDTF=$SELECT(FBBAT:$$GET1^DIQ(161.7,FBBAT_",",13,"I"),1:"")
+41 IF FBDTF
IF FBDTF<FBDT132
SET FBOLD=1
+42 IF 'FBOLD
IF FBDTP
IF FBDTP<FBDT132
SET FBOLD=1
+43 IF 'FBOLD
IF FBDTC
IF FBDTC<FBDT132
SET FBOLD=1
+44 ; don't delete if not an old payment
+45 IF 'FBOLD
SET FBC("NOLD")=FBC("NOLD")+1
QUIT 0
+46 ;
+47 ; passed all checks to delete the reject flag
+48 SET FBC("DELR")=FBC("DELR")+1
+49 QUIT 1
+50 ;
INITCNT ; initalize counters for file/sub-file
+1 ; count of line items flagged as rejected
SET FBC("REJ")=0
+2 ; count of rejected line items with pay conf/canc
SET FBC("REJC")=0
+3 ; count of inapp. rejects not vouchered so not deleted
SET FBC("NVOU")=0
+4 ; count of inapp. rejects not old so not deleted
SET FBC("NOLD")=0
+5 ; count of reject flags deleted
SET FBC("DELR")=0
+6 QUIT
SHOWCNT ; show counts for file/sub-file
+1 NEW FBTYPE,FBX
+2 IF FBFILE=162.03
SET FBTYPE="outpatient/ancillary"
+3 IF FBFILE=162.04
SET FBTYPE="travel"
+4 IF FBFILE=162.11
SET FBTYPE="pharmacy"
+5 IF FBFILE=162.5
SET FBTYPE="inpatient"
+6 SET FBX=$JUSTIFY($FNUMBER(FBC("REJ"),","),10)_" "_FBTYPE_" payment lines were flagged as rejected."
+7 DO MES^XPDUTL(FBX)
+8 SET FBX=$JUSTIFY($FNUMBER(FBC("REJC"),","),10)_" of these rejects are inappropriate because the payment line"
+9 DO MES^XPDUTL(FBX)
+10 SET FBX=" also has payment confirmation or payment cancellation data."
+11 DO MES^XPDUTL(FBX)
+12 SET FBX=$JUSTIFY($FNUMBER(FBC("DELR"),","),10)_" of the inappropriate reject flags were deleted."
+13 DO MES^XPDUTL(FBX)
+14 IF FBC("NVOU")>0
Begin DoDot:1
+15 SET FBX=$JUSTIFY($FNUMBER(FBC("NVOU"),","),10)_" of the inappropriate reject flags could not be deleted"
+16 DO MES^XPDUTL(FBX)
+17 SET FBX=" because the batch status is not vouchered."
+18 DO MES^XPDUTL(FBX)
End DoDot:1
+19 IF FBC("NOLD")>0
Begin DoDot:1
+20 SET FBX=$JUSTIFY($FNUMBER(FBC("NOLD"),","),10)_" of the inappropriate reject flags could not be deleted"
+21 DO MES^XPDUTL(FBX)
+22 SET FBX=" because the payment is not prior to "_$$FMTE^XLFDT(FBDT132)_"."
+23 DO MES^XPDUTL(FBX)
End DoDot:1
+24 QUIT
+25 ;
+26 ;FBXIP165
