- 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 Jan 18, 2025@03:01:07 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