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

BARCLU4.m

Go to the documentation of this file. 
  1. BARCLU4 ; IHS/SD/LSL - COLLECTION BATCH PREPAYMENTS ;; 07/09/2010
  1.  ;;1.8;IHS ACCOUNTS RECEIVABLE;**19**;OCT 26, 2005
  1.  ;;
  1.  ; 
  1.  ; IHS/SD/TMM 06/18/2010 1.8*Patch 19 (M819), Add Prepayment functionality.
  1.  ;      See work order 3PMS10001
  1.  ;      ------------------------
  1.  ;      BARCLU is a new routine adding Prepayment functionality to collection entry.
  1.  ;      819_1. Display prepayments not assigned to a batch (^BARCLU,^BARCLU4)
  1.  ;      819_2. Remove prompt: AUTO PRINT RECEIPT (^BARCLU01)
  1.  ;      819_3. Prepayment entry ^BARPPY01 (new routine),^BARCLU1,^BARPUTL
  1.  ;      819_4. Display prepayments matching payment type selected (^BARCLU,^BARCLU4)
  1.  ;      819_5. Allow user to assign prepayment to batch (^BARCLU,^BARCLU4,^BARCLU01,^BARPUTL,^BARPST1,^BARBLLK)
  1.  ;      819_6. Print Prepayment Receipt (^BARPPY02) (new routine)
  1.  ; ********************************************************************* ;
  1.  ;
  1.  ;--->New Tag DISPPAY  ;M819*ADD*TMM*20100710 (819_1)
  1. DISPPAY ;   Display all Prepayments not assigned to a collection batch
  1.  D PPCLEAN
  1.  I '$D(^BARPPAY(DUZ(2),"F","N")) Q    ;there are no unassigned prepayments
  1.  W !!!!,"**PAYMENTS EXIST THAT HAVE NOT BEEN BATCHED. PLEASE REVIEW AND ADD TO A COLLECTION BATCH**"
  1.  W !!
  1.  I BARCLID(2,"I")'="A" Q     ;display only if Collection Point BATCH TYPE = ALL TYPES
  1.  ; "F" = Index
  1.  ; "N" = Prepayment BATCH FLAG 'N'ot Assigned to batch
  1.  S BARCNTPP=0
  1.  S BARPMTYP="" F  S BARPMTYP=$O(^BARPPAY(DUZ(2),"F","N",BARPMTYP)) Q:BARPMTYP=""  D
  1.  . S BARPMTDT="" F  S BARPMTDT=$O(^BARPPAY(DUZ(2),"F","N",BARPMTYP,BARPMTDT)) Q:'BARPMTDT  D
  1.  .. S BARPPIEN="" F  S BARPPIEN=$O(^BARPPAY(DUZ(2),"F","N",BARPMTYP,BARPMTDT,BARPPIEN)) Q:'BARPPIEN  D
  1.  ... K BARPPAY            ;kill array so last DA is not used
  1.  ... D BARPPAY^BARCLU1(BARPPIEN)    ;builds BARPPAY array
  1.  ... S BARCNTPP=BARCNTPP+1
  1.  ... S BARPPAMT=$J($FN(BARPPAY(.07),",",2),11) ;credit (payment amount)
  1.  ... S BARPAYTY=$E(BARPPAY(.03),1,6)         ;payment type
  1.  ... S BARPMTDI=BARPPAY(.02,"I")             ;payment date (FM format)
  1.  ... S BARPMTMM=$E(BARPMTDI,4,5)
  1.  ... S BARPMTDD=$E(BARPMTDI,6,7)
  1.  ... S BARPMTYY=$E(BARPMTDI,1,3)+1700
  1.  ... S BARPMTYY=$E(BARPMTYY,3,4)
  1.  ... S BARPAYDT=BARPMTMM_"/"_BARPMTDD_"/"_BARPMTYY
  1.  ... S BARECPT=$E(BARPPAY(.01),1,16)      ;receipt number
  1.  ... S BARPTNM=$E(BARPPAY(.08),1,20)      ;patient name
  1.  ... S BARPPCMT=$E($G(BARPPAY(101,1)),1,9)      ;comment line 1
  1.  ... W !,BARCNTPP,".",?5,BARPPAMT,?17,BARPAYTY,?24,BARPAYDT,?33,BARECPT,?50,BARPTNM,?71,BARPPCMT
  1.  W !
  1.  D PAZ^BARRUTL    ;Press return to continue
  1.  K BARPPAY
  1.  Q
  1.  ;
  1.  Q
  1.  ;
  1.  ;--->New Tag SELPPAY  ;M819*ADD*TMM*20100710 (819_4)
  1. SELPPAY ;	Display and select prepayments matching selected payment type
  1.  ;----  51:EOB 52:CASH 53:CC 55:REFUND 81:CHECK
  1.  D PPCLEAN
  1.  ;M819*DEL*TMM*20100714***  K BARPP,BARPPAY
  1.  S BARPMTYP=$S(BARX=52:"CA",BARX=53:"CC",BARX=81:"CK",1:"")
  1.  I BARPMTYP="" Q    ;Payment Type not defined
  1.  ;Stop prepayment processing if no unassigned prepayments
  1.  I '$D(^BARPPAY(DUZ(2),"F","N",BARPMTYP)) D  Q:BARNOPP
  1.  . ;Check for Debit Card entries in Prepayment file if batch payment type is Credit Card
  1.  . S BARNOPP=1        ;no further checking if not a Credit Card payment type 
  1.  . Q:BARPMTYP'="CC"
  1.  . S BARNOPP=0
  1.  . I '$D(^BARPPAY(DUZ(2),"F","N","DB")) S BARNOPP=1  ;check for debit prepayments
  1.  I BARPMTYP'="CC" D
  1.  . S BARCNTPP=0
  1.  . S BARPMTDT="" F  S BARPMTDT=$O(^BARPPAY(DUZ(2),"F","N",BARPMTYP,BARPMTDT)) Q:'BARPMTDT  D
  1.  .. D SELPPAY1  ;display matching prepayments (not Credits and Debits)
  1.  I BARPMTYP="CC" D
  1.  . S BARCNTPP=0
  1.  . W !!
  1.  . F BARPMTYP="CC","DB" D
  1.  .. S BARPMTDT="" F  S BARPMTDT=$O(^BARPPAY(DUZ(2),"F","N",BARPMTYP,BARPMTDT)) Q:'BARPMTDT  D
  1.  ... D SELPPAY1  ;display matching Credit and Debit prepayments
  1.  . S BARPMTYP="CC"
  1.  W !!
  1.  ; Prompt for selection
  1.  K DIR
  1.  S DIR(0)="NAO^1:"_BARCNTPP
  1.  S DIR("A")="Select Entry to batch or <Enter> to proceed:  "
  1.  D ^DIR
  1.  Q:$D(DTOUT)!($D(DUOUT))
  1.  Q:(Y="")
  1.  S BARSELPP=Y         ;Line # of selected prepayment item
  1.  ; 
  1.  W !!
  1.  S BARPPIEN=$G(BARPP(BARSELPP))
  1.  S BARPPDAT=$G(BARPP(BARSELPP,BARPPIEN))
  1.  S DIR("A",1)="You selected line "_BARSELPP
  1.  S DIR("A",2)=" "
  1.  S DIR("A",3)=BARSELPP_"."_BARPPDAT
  1.  S DIR("A",4)=" "
  1.  S DIR("A")="Are you sure this is what you want?  "
  1.  S DIR("B")="YES"
  1.  S DIR(0)="YA"
  1.  D ^DIR
  1.  I Y<1 G SELPPAY
  1.  S BARPPSEL=1                   ;Prepayment item selected
  1.  D BARPPAY^BARCLU1(BARPPIEN)    ;builds BARPPAY array
  1.  Q
  1.  ;
  1.  ;--->New Tag SELPPAY1  ;M819*ADD*TMM*20100710 (819_4)
  1. SELPPAY1 ;  Display and select prepayment for this batch item
  1.  ; "F" = Index
  1.  ; "N" = Prepayment BATCH FLAG 'N'ot Assigned to batch
  1.  S BARPPIEN="" F  S BARPPIEN=$O(^BARPPAY(DUZ(2),"F","N",BARPMTYP,BARPMTDT,BARPPIEN)) Q:'BARPPIEN  D
  1.  . K BARPPAY    ;kill array so last DA is not used
  1.  . D BARPPAY^BARCLU1(BARPPIEN)    ;builds BARPPAY array
  1.  . S BARCNTPP=BARCNTPP+1
  1.  . S BARPPAMT=$J($FN(BARPPAY(.07),",",2),11) ;credit (payment amount)
  1.  . S BARPAYTY=$E(BARPPAY(.03),1,6)         ;payment type
  1.  . S BARPMTDI=BARPPAY(.02,"I")             ;payment date (FM format)
  1.  . S BARPMTMM=$E(BARPMTDI,4,5)
  1.  . S BARPMTDD=$E(BARPMTDI,6,7)
  1.  . S BARPMTYY=$E(BARPMTDI,1,3)+1700
  1.  . S BARPMTYY=$E(BARPMTYY,3,4)
  1.  . S BARPAYDT=BARPMTMM_"/"_BARPMTDD_"/"_BARPMTYY
  1.  . S BARECPT=$E(BARPPAY(.01),1,16)      ;receipt number
  1.  . S BARPTNM=$E(BARPPAY(.08),1,20)      ;patient name
  1.  . S BARPPCMT=$E($G(BARPPAY(101,1)),1,9)      ;comment line 1
  1.  . W !,BARCNTPP,".",?5,BARPPAMT,?17,BARPAYTY,?24,BARPAYDT,?33,BARECPT,?50,BARPTNM,?71,BARPPCMT
  1.  . S BARPP(BARCNTPP)=BARPPIEN
  1.  . S BARPP(BARCNTPP,BARPPIEN)=BARPPAMT_" "_BARPAYTY_" "_BARPAYDT_" "_BARECPT_" "_BARPTNM_" "_BARPPCMT
  1.  Q
  1.  ;
  1. PPUPDT ;  Update batch assignment fields in Prepayment file
  1.  ;--->New Tag PPUPDT  ;M819*ADD*TMM*20100710 (819_4)
  1.  K DIE,DR,DA
  1.  S DR=".14////^S X=BARCLDA"      ;BATCH
  1.  S DR=DR_";.15////^S X=BARITDA"      ;ITEM
  1.  D NOW^%DTC
  1.  S BARPPDTM=$P(%,".")
  1.  S DR=DR_";.16////^S X=BARPPDTM"      ;ASSIGNED TO BATCH DT/TM
  1.  S DR=DR_";.17////^S X=DUZ"      ;ASSIGNED TO BATCH BY USER
  1.  ; .18 BATCH ASSIGNMENT field update is triggered when field 14 is updated
  1.  ; Update Pre-Payment file
  1.  S DA=BARPPIEN
  1.  S DIE=$$DIC^XBDIQ1(90050.06)
  1.  D ^DIE
  1.  K DIE,DA,DR
  1.  ;
  1. PPUPDT1 ;Update Prepayment receipt # for batch item
  1.  ;--->New Tag PPUPDT1  ;M819*ADD*TMM*20100710 (819_4)
  1.  S BARDIC="^BARCOL(DUZ(2),"
  1.  S DIE=BARDIC_BARCLDA_",1,"
  1.  S DA=BARITDA
  1.  S DA(1)=BARCLDA
  1.  ;S DR="23////"_BARPPIEN
  1.  S DR="23////^S X=BARPPIEN"
  1.  D ^DIE
  1.  D PPCLEAN
  1.  Q
  1.  ;
  1. PPCLEAN ;  Clear Prepayment variables in Prepayment fields
  1.  K BARCNTPP,BARECPT,BARNOPP,BARPAYDT,BARPAYTY,BARPMTDD,BARPMTDI,BARPMTDT
  1.  K BARPMTMM,BARPMTYP,BARPMTYY,BARPP,BARPPAMT,BARPPAY,BARPPBDS,BARPPCMT,BARPPDTM
  1.  K BARPPIEN,BARPPSEL,BARPTNM,BARSELPP,BARTMPBL,DICB,DICB2,DICB3
  1.  Q
  1.  ;
  1. NEWITEM ;EP setup for auto adding a new item
  1.  S X=BARCL(7)+1
  1.  S BARCL(7)=X           ;last receipt #
  1.  S DA(1)=BARCLDA
  1.  S DIC="XL"
  1.  S DIC("P")=$P(^DD(90051.01,101,0),U,2)
  1.  S DIC="^BARCOL(DUZ(2),"_DA(1)_",1,"
  1.  S DIC(0)="EXQML"
  1.  ;
  1.  ;   3 = Payment Type
  1.  ;   4 = Date/time Stamp
  1.  ;   20 = TDN/IPAC
  1.  ;S DIC("DR")="3///NOW;4////^S X=DUZ"  ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1.  S DIC("DR")="3///NOW;4////^S X=DUZ;20////"_$P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)  ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1.  S DINUM=X
  1.  K DD,DO
  1.  S DLAYGO=90050
  1.  K DD,DO
  1.  D FILE^DICN
  1.  K DLAYGO,DIC("P")
  1.  I Y'>0 D  Q
  1.  . W !!,"error in setting new entry",!!
  1.  . D EOP^BARUTL(1)
  1.  S BARITDA=+Y
  1.  K DR,DIC,DIE,DA
  1.  S DA=BARITDA
  1.  S DA(1)=BARCLDA
  1.  S DIE=BARDIC_BARCLDA_",1,"
  1.  Q
  1.  ; *********************************************************************