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

BARNCPDP.m

Go to the documentation of this file. 
  1. BARNCPDP ; IHS/SD/LSL - Post NCPDP Reject/Payment Codes ; 
  1.  ;;1.8;IHS ACCOUNTS RECEIVABLE;**1**;MAR 27,2007
  1.  ;
  1.  ; IHS/SD/LSL - 03/04/04 - V1.7 Patch 5
  1.  ;     Routine created.  Post NCPDP Reject/Payment Codes.
  1.  ;
  1.  Q
  1.  ; ********************************************************************
  1.  ;
  1. EN ; EP
  1.  D ^BARVKL0                    ; kill namespace variables
  1.  S BARESIG=""                  ; BAR electronic signature flag
  1.  D SIG^XUSESIG Q:X1=""         ; elec sig test - Q if fail
  1.  S BARESIG=1                   ; passed elec sig test
  1.  S (BARDONE,BARCOL,BARITM)=0
  1.  I '$D(BARUSR) D INIT^BARUTL   ; Initialize BAR environment
  1.  D BATCHITM                    ; Ask Collection Batch/Item
  1.  I '+BARCOL!'+BARITM D MSG   ; Double check no batch/item
  1.  I +BARDONE D XIT Q
  1.  I +BARCOL,+BARITM,+$P(^BAR(90052.06,DUZ(2),DUZ(2),0),U,2) D FAC
  1.  S BARBDONE=0
  1.  F  D BILLS Q:+BARBDONE        ; Ask bills and codes and post
  1.  D XIT
  1.  Q
  1.  ;*********************************************************************
  1.  ;
  1. BATCHITM ;
  1.  ; Ask Collection Batch and Item (not required)
  1.  D BATCH^BARFPST               ; Ask Collection Batch
  1.  I +BARCOL D ITEM^BARFPST    ; If batch, ask item
  1.  Q
  1.  ; ********************************************************************
  1.  ;
  1. MSG ;
  1.  ; If no batch/item, give user chance to select.
  1.  K DIR
  1.  S DIR("A")="A valid collection batch and item was not entered.  Continue"
  1.  S DIR("B")="N"
  1.  S DIR(0)="Y"
  1.  D ^DIR
  1.  Q:+Y
  1.  ;
  1.  K DIR
  1.  S DIR("A")="Do you want to enter a new collection batch and item"
  1.  S DIR("B")="Y"
  1.  S DIR(0)="Y"
  1.  I '+Y S BARDONE=1 Q
  1.  K BARCOL,BARITM
  1.  D BATCHITM
  1.  I '+BARCOL!'+BARITM S BARDONE=1
  1.  Q
  1.  ; ********************************************************************
  1.  ;
  1. FAC ;
  1.  ; I multiple EOB site parameter, do...
  1.  D FAC^BARFPST               ;eob
  1.  I Y>0 D
  1.  . S BAREOB=+Y
  1.  . S BAREOB(0)=Y(0)
  1.  . D EBAL^BARPST(BAREOB)
  1.  Q
  1.  ; ********************************************************************
  1.  ;
  1. BILLS ;
  1.  ; Loop bills, select remark codes and post
  1.  D SELBILL
  1.  ;Q:'+BARBL
  1.  Q:'+$G(BARBL)  ;IHS/SD/TPF 12/6/2005 IM15742 BAR*1.8*1
  1.  Q:+BARBDONE
  1.  S BARRDONE=0
  1.  K BARMK
  1.  F  D SELNCPDP Q:+BARRDONE
  1.  Q:'$D(BARMK)                      ; No remark codes to post
  1.  D REVIEW                          ; Review selection
  1.  I '+BARANS D  Q
  1.  . W !!,"NCPDP Reject/Payment Codes not posted!"
  1.  . K DIR
  1.  . D EOP^BARUTL(1)
  1.  D POSTCD                          ; Post remark code
  1.  K DIR
  1.  D EOP^BARUTL(1)
  1.  Q
  1.  ; ********************************************************************
  1.  ;
  1. SELBILL ; EP
  1.  ; Ask user for bill
  1.  K BARFPASS,DIC,DD,D0,X,Y,BARZ
  1.  W $$EN^BARVDF("IOF")
  1.  W !
  1.  S BARFPASS=$$GETBIL^BARFPST3      ; Get bills by bill, patient, or DOS
  1.  I BARFPASS=0 S BARBDONE=1 Q       ; No bill selected; End loop
  1.  S BARPASS=$P(BARFPASS,U,1,3)      ; Patient^DOS Start^DOS End
  1.  ; If no A/R Bill IEN
  1.  I '+$P(BARFPASS,U,4) D FINDBIL^BARFPST3
  1.  I '+$P(BARFPASS,U,4) Q            ; bill not found - ask again
  1.  S BARBL=$P(BARFPASS,U,4)
  1.  Q
  1.  ; ********************************************************************
  1.  ;
  1. SELNCPDP ;
  1.  ; Select NCPDP Reject/Payment codes
  1.  W !
  1.  K DIC,DR,DA,Y,X
  1.  S DIC="^ABSPF(9002313.93,"
  1.  S DIC(0)="AEMQZ"
  1.  S DIC("A")="Select NCPDP Reject Payment Code: "
  1.  I $D(BARMK) S DIC("A")="Select Additional NCPDP Reject Payment Code: "
  1.  S DIC("W")="W ?40,$P(^(0),U,2)"
  1.  K DD,D0
  1.  D ^DIC
  1.  I +Y>0 S BARMK(+Y)=Y(0) Q
  1.  S BARRDONE=1
  1.  Q
  1.  ; ********************************************************************
  1.  ;
  1. REVIEW ;
  1.  ; Display stuff to post...
  1.  S $P(BARSTAR,"*",81)=""
  1.  D GETS^DIQ(90050.01,BARBL,".01;3;7.2;15;17.2;18;101:103;108","IE","BARDAT")
  1.  M BARDATA=BARDAT(90050.01,BARBL_",")
  1.  I '$D(BAREOB) S BAREOB=BARDATA(108,"I")
  1.  W $$EN^BARVDF("IOF")
  1.  W !?1,"BILL #: ",$E(BARDATA(.01,"E"),1,25)
  1.  W ?36,"DATE BILLED:",?50,BARDATA(18,"E")
  1.  W !,"PATIENT: ",$E(BARDATA(101,"E"),1,25)
  1.  W ?36,"AGE OF BILL:",?50,$J(BARDATA(7.2,"E"),5),"  DAYS"
  1.  W !?2,"CHART: ",$P($G(^AUPNPAT(BARDATA(101,"I"),41,BAREOB,0)),U,2)
  1.  W ?36,"BILL STATUS:",?50,BARDATA(17.2,"E")
  1.  W !!?4,"DOS: ",BARDATA(102,"E")
  1.  W ?39,"A/R ACCT:",?50,$E(BARDATA(3,"E"),1,30)
  1.  I BARDATA(102,"I")'=BARDATA(103,"I") W !?5,"TO: ",BARDATA(103,"E")
  1.  W !,BARSTAR
  1.  S I=0
  1.  F  S I=$O(BARMK(I)) Q:'+I  D
  1.  . W !,$P(BARMK(I),U)
  1.  . W !,$P(BARMK(I),U,2),!
  1.  W BARSTAR
  1.  K DIR
  1.  S DIR(0)="Y"
  1.  S DIR("A")="Post these NCPDP Reject/Payment codes to this bill"
  1.  S DIR("B")="Y"
  1.  D ^DIR
  1.  S BARANS=+Y
  1.  Q
  1.  ; ********************************************************************
  1.  ;
  1. POSTCD ;
  1.  K BARDR
  1.  ; Post selected remark codes to selected bill.
  1.  S BARDR="4////^S X=BARBL"                        ; A/R Bill
  1.  S BARDR=BARDR_";5////^S X=BARDATA(101,""I"")"              ; A/R Patient
  1.  S BARDR=BARDR_";6////^S X=BARDATA(3,""I"")"               ; A/R Account
  1.  S BARDR=BARDR_";8////^S X=DUZ(2)"                ; Parent Location
  1.  S BARDR=BARDR_";9////^S X=DUZ(2)"                ; Parent ASUFAC
  1.  ; Force A/R section to Business Office
  1.  S BARDR=BARDR_";10////8"                         ; A/R Section
  1.  S BARDR=BARDR_";11////^S X=BAREOB"               ; Visit Location
  1.  S BARDR=BARDR_";12////^S X=DT"                   ; Date
  1.  S BARDR=BARDR_";13////^S X=DUZ"        ; Entry by
  1.  S BARDR=BARDR_";101////506"             ; Tran Type = Remark Code
  1.  S BARDR=BARDR_";108////^S X=BARMKCD"
  1.  I +BARCOL,+BARITM D                        ; If collection batch/item
  1.  . S BARDR=BARDR_";14////^S X=BARCOL"
  1.  . S BARDR=BARDR_";15////^S X=BARITM"
  1.  ;
  1.  S DIE=90050.03
  1.  S DIDEL=90050
  1.  S BARMKCD=0
  1.  W !
  1.  F  S BARMKCD=$O(BARMK(BARMKCD)) Q:'+BARMKCD  D
  1.  . K DR,DA
  1.  . W !,"Posting NCPDP Reject/Payment Code ",$P(BARMK(BARMKCD),U)
  1.  . S BARTRIEN=$$NEW^BARTR                     ; Create New Transaction
  1.  . I +BARTRIEN<1 D MSG^BARTR(BARBL) Q
  1.  . ; Populate Transaction file
  1.  . S DA=BARTRIEN                              ; IEN to A/R TRANSACTION
  1.  . S DR=BARDR
  1.  . D ^DIE
  1.  K DIDEL,DIE,DA,DR,DIR
  1.  Q
  1.  ; ********************************************************************
  1.  ;
  1. XIT ;
  1.  W $$EN^BARVDF("IOF")
  1.  D ^BARVKL0
  1.  Q