FBRXFR ;WOIFO/SAB-FILE REMITTANCE REMARKS FOR PHARMACY PAYMENT ;7/17/2003
;;3.5;FEE BASIS;**61,158**;JAN 30, 1995;Build 94
;;Per VA Directive 6402, this routine should not be modified.
Q
FILERR(FBIENS,FBRRMK) ; File Remittance Remakrs
;
; Input
; FBIENS - required, internal entry numbers for subfile 162.11
; in standard format as specified for FileMan DBS calls
; FBRRMK - required, array passed by reference
; array of remittance remarks to file
; array does not have to contain any data or be defined
; format
; FBRRMK(FBADJ,#)=FBRRMKC
; where
; FBADJ = Adjustment Reason IEN (internal value from file 161.91)
; # = sequentially assigned number starting with 1
; FBRRMKC = remittance remark (internal value file 162.93)
; Output
; Data in File 162.11 will be modified
;
N FB,FBFDA,FBI,FBSIENS,FBADJ,FBDA,CNTR,ADJDA
;
; delete remitance remarks currently on file
D GETS^DIQ(162.11,FBIENS,"38*","IE","FB")
K FBFDA
S FBSIENS="" F S FBSIENS=$O(FB(162.15,FBSIENS)) Q:FBSIENS="" D
. S FBFDA(162.15,FBSIENS,.01)="@"
I $D(FBFDA) D FILE^DIE("","FBFDA")
;
; file remarks from input array
K FBFDA
S (FBADJ,CNTR)=0
D DA^DILF(FBIENS,.FBDA)
F S FBADJ=$O(FBRRMK(FBADJ)) Q:'FBADJ D
. ;S ADJDA=$$GETADJI(FBADJ,.FBDA)
. S ADJDA=$S(FBADJ'=999:$$GETADJI(FBADJ,.FBDA),1:FBADJ) ;999 indicates a CARCless RARC
. S FBI=0
. F S FBI=$O(FBRRMK(FBADJ,FBI)) Q:'FBI D
. . S CNTR=CNTR+1
. . S FBFDA(162.15,"+"_CNTR_","_FBIENS,.01)=$P(FBRRMK(FBADJ,FBI),U)
. . S FBFDA(162.15,"+"_CNTR_","_FBIENS,1)=ADJDA
I $D(FBFDA) D UPDATE^DIE("","FBFDA")
;
Q
;
GETADJI(ADJI,FBDA) ; get correct DA from ADJUSTMENT multiple
;
N DA
I $D(FBDA)'=11 Q ""
S DA=""
I $G(ADJI),$D(^FBAA(162.1,FBDA(1),"RX",FBDA,4,"B",ADJI)) D
. S DA=$O(^FBAA(162.1,FBDA(1),"RX",FBDA,4,"B",ADJI,DA))
Q DA
;
LOADRR(FBIENS,FBRRMK) ; Load Remittance Remarks
; Input
; FBIENS - required, internal entry numbers for subfile 162.11
; in standard format as specified for FileMan DBS calls
; FBRRMK - required, array passed by reference
; array to load adjustments into
; Output
; FBRRMK - the FBRRMK input array passed by reference will be modified
; format
; FBRRMK(#)=FBRRMKC
; where
; # = sequentially assigned number starting with 1
; FBRRMKC = remittance remark (internal value file 162.93)
; if no remarks are on file then the array will be undefined
N FB,FBC,FBI,FBSIENS,ADJMI,FBDA,RRI,ADJI
;
K FBRRMK
;
S FBC=0,ADJMI=""
D DA^DILF(FBIENS,.FBDA)
D GETS^DIQ(162.11,FBIENS,"38*","I","FB")
S FBSIENS=""
F S FBSIENS=$O(FB(162.15,FBSIENS)) Q:FBSIENS="" D
. S RRI=FB(162.15,FBSIENS,.01,"I")
. S ADJMI=FB(162.15,FBSIENS,1,"I")
. I ADJMI,$D(^FBAA(162.1,FBDA(1),"RX",FBDA,4,ADJMI,0)) D
. . S ADJI=$P(^FBAA(162.1,FBDA(1),"RX",FBDA,4,ADJMI,0),U)
. E S ADJI=999
. S FBC=$S($D(FBRRMK(ADJI)):$O(FBRRMK(ADJI,FBC)),1:0)
. S FBRRMK(ADJI,FBC+1)=RRI
;
Q
;
RRL(FBIENS) ; Remittance Remarks List Extrinsic Function
; Input
; FBIENS - required, internal entry numbers for subfile 162.11
; in standard format as specified for FileMan DBS calls
; Result
; string containing sorted list (by external code) of remarks
; format
; FBRRMKCE 1, FBRRMKCE 2
; where
; FBRRMKCE = remittance remark code (external value)
N FBRET,FBRRMK
D LOADRR^FBRXFR(FBIENS,.FBRRMK)
S FBRET=$$RRL^FBUTL4(.FBRRMK)
Q FBRET
;
KILLRR(X,DA) ; Called from FEE BASIS PHARMACY INVOICE (#162.1),
; ADJUSTMENT (#162.11,37), ADJUSTMENT REASON (162.14, .01)
; to delete REMITTANCE REMARK (#162.11,38) entries associated
; with adjustment reasons being deleted.
;
N FBIENS,FB,FBFDA,FBSIENS
;
S FBIENS=$G(DA(1))_","_$G(DA(2))_","
D GETS^DIQ(162.11,FBIENS,"38*","","FB")
;
S FBSIENS="" F S FBSIENS=$O(FB(162.15,FBSIENS)) Q:FBSIENS="" D
. I FB(162.15,FBSIENS,1)=$G(DA) S FBFDA(162.15,FBSIENS,.01)="@"
I $D(FBFDA) D FILE^DIE("","FBFDA")
;
Q
;FBRXFR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBRXFR 4256 printed Oct 16, 2024@18:00:44 Page 2
FBRXFR ;WOIFO/SAB-FILE REMITTANCE REMARKS FOR PHARMACY PAYMENT ;7/17/2003
+1 ;;3.5;FEE BASIS;**61,158**;JAN 30, 1995;Build 94
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
FILERR(FBIENS,FBRRMK) ; File Remittance Remakrs
+1 ;
+2 ; Input
+3 ; FBIENS - required, internal entry numbers for subfile 162.11
+4 ; in standard format as specified for FileMan DBS calls
+5 ; FBRRMK - required, array passed by reference
+6 ; array of remittance remarks to file
+7 ; array does not have to contain any data or be defined
+8 ; format
+9 ; FBRRMK(FBADJ,#)=FBRRMKC
+10 ; where
+11 ; FBADJ = Adjustment Reason IEN (internal value from file 161.91)
+12 ; # = sequentially assigned number starting with 1
+13 ; FBRRMKC = remittance remark (internal value file 162.93)
+14 ; Output
+15 ; Data in File 162.11 will be modified
+16 ;
+17 NEW FB,FBFDA,FBI,FBSIENS,FBADJ,FBDA,CNTR,ADJDA
+18 ;
+19 ; delete remitance remarks currently on file
+20 DO GETS^DIQ(162.11,FBIENS,"38*","IE","FB")
+21 KILL FBFDA
+22 SET FBSIENS=""
FOR
SET FBSIENS=$ORDER(FB(162.15,FBSIENS))
if FBSIENS=""
QUIT
Begin DoDot:1
+23 SET FBFDA(162.15,FBSIENS,.01)="@"
End DoDot:1
+24 IF $DATA(FBFDA)
DO FILE^DIE("","FBFDA")
+25 ;
+26 ; file remarks from input array
+27 KILL FBFDA
+28 SET (FBADJ,CNTR)=0
+29 DO DA^DILF(FBIENS,.FBDA)
+30 FOR
SET FBADJ=$ORDER(FBRRMK(FBADJ))
if 'FBADJ
QUIT
Begin DoDot:1
+31 ;S ADJDA=$$GETADJI(FBADJ,.FBDA)
+32 ;999 indicates a CARCless RARC
SET ADJDA=$SELECT(FBADJ'=999:$$GETADJI(FBADJ,.FBDA),1:FBADJ)
+33 SET FBI=0
+34 FOR
SET FBI=$ORDER(FBRRMK(FBADJ,FBI))
if 'FBI
QUIT
Begin DoDot:2
+35 SET CNTR=CNTR+1
+36 SET FBFDA(162.15,"+"_CNTR_","_FBIENS,.01)=$PIECE(FBRRMK(FBADJ,FBI),U)
+37 SET FBFDA(162.15,"+"_CNTR_","_FBIENS,1)=ADJDA
End DoDot:2
End DoDot:1
+38 IF $DATA(FBFDA)
DO UPDATE^DIE("","FBFDA")
+39 ;
+40 QUIT
+41 ;
GETADJI(ADJI,FBDA) ; get correct DA from ADJUSTMENT multiple
+1 ;
+2 NEW DA
+3 IF $DATA(FBDA)'=11
QUIT ""
+4 SET DA=""
+5 IF $GET(ADJI)
IF $DATA(^FBAA(162.1,FBDA(1),"RX",FBDA,4,"B",ADJI))
Begin DoDot:1
+6 SET DA=$ORDER(^FBAA(162.1,FBDA(1),"RX",FBDA,4,"B",ADJI,DA))
End DoDot:1
+7 QUIT DA
+8 ;
LOADRR(FBIENS,FBRRMK) ; Load Remittance Remarks
+1 ; Input
+2 ; FBIENS - required, internal entry numbers for subfile 162.11
+3 ; in standard format as specified for FileMan DBS calls
+4 ; FBRRMK - required, array passed by reference
+5 ; array to load adjustments into
+6 ; Output
+7 ; FBRRMK - the FBRRMK input array passed by reference will be modified
+8 ; format
+9 ; FBRRMK(#)=FBRRMKC
+10 ; where
+11 ; # = sequentially assigned number starting with 1
+12 ; FBRRMKC = remittance remark (internal value file 162.93)
+13 ; if no remarks are on file then the array will be undefined
+14 NEW FB,FBC,FBI,FBSIENS,ADJMI,FBDA,RRI,ADJI
+15 ;
+16 KILL FBRRMK
+17 ;
+18 SET FBC=0
SET ADJMI=""
+19 DO DA^DILF(FBIENS,.FBDA)
+20 DO GETS^DIQ(162.11,FBIENS,"38*","I","FB")
+21 SET FBSIENS=""
+22 FOR
SET FBSIENS=$ORDER(FB(162.15,FBSIENS))
if FBSIENS=""
QUIT
Begin DoDot:1
+23 SET RRI=FB(162.15,FBSIENS,.01,"I")
+24 SET ADJMI=FB(162.15,FBSIENS,1,"I")
+25 IF ADJMI
IF $DATA(^FBAA(162.1,FBDA(1),"RX",FBDA,4,ADJMI,0))
Begin DoDot:2
+26 SET ADJI=$PIECE(^FBAA(162.1,FBDA(1),"RX",FBDA,4,ADJMI,0),U)
End DoDot:2
+27 IF '$TEST
SET ADJI=999
+28 SET FBC=$SELECT($DATA(FBRRMK(ADJI)):$ORDER(FBRRMK(ADJI,FBC)),1:0)
+29 SET FBRRMK(ADJI,FBC+1)=RRI
End DoDot:1
+30 ;
+31 QUIT
+32 ;
RRL(FBIENS) ; Remittance Remarks List Extrinsic Function
+1 ; Input
+2 ; FBIENS - required, internal entry numbers for subfile 162.11
+3 ; in standard format as specified for FileMan DBS calls
+4 ; Result
+5 ; string containing sorted list (by external code) of remarks
+6 ; format
+7 ; FBRRMKCE 1, FBRRMKCE 2
+8 ; where
+9 ; FBRRMKCE = remittance remark code (external value)
+10 NEW FBRET,FBRRMK
+11 DO LOADRR^FBRXFR(FBIENS,.FBRRMK)
+12 SET FBRET=$$RRL^FBUTL4(.FBRRMK)
+13 QUIT FBRET
+14 ;
KILLRR(X,DA) ; Called from FEE BASIS PHARMACY INVOICE (#162.1),
+1 ; ADJUSTMENT (#162.11,37), ADJUSTMENT REASON (162.14, .01)
+2 ; to delete REMITTANCE REMARK (#162.11,38) entries associated
+3 ; with adjustment reasons being deleted.
+4 ;
+5 NEW FBIENS,FB,FBFDA,FBSIENS
+6 ;
+7 SET FBIENS=$GET(DA(1))_","_$GET(DA(2))_","
+8 DO GETS^DIQ(162.11,FBIENS,"38*","","FB")
+9 ;
+10 SET FBSIENS=""
FOR
SET FBSIENS=$ORDER(FB(162.15,FBSIENS))
if FBSIENS=""
QUIT
Begin DoDot:1
+11 IF FB(162.15,FBSIENS,1)=$GET(DA)
SET FBFDA(162.15,FBSIENS,.01)="@"
End DoDot:1
+12 IF $DATA(FBFDA)
DO FILE^DIE("","FBFDA")
+13 ;
+14 QUIT
+15 ;FBRXFR
