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

BARCLU01.m

Go to the documentation of this file.
  1. BARCLU01 ; IHS/SD/LSL - Split out of BARCLU0 ;; 07/09/2010
  1. ;;1.8;IHS ACCOUNTS RECEIVABLE;**3,4,19,22,28**;OCT 26, 2005;Build 92
  1. ;;
  1. ; IHS/SD/TMM 06/18/2010 1.8*Patch 19 (M819), Add Prepayment functionality.
  1. ; See work order 3PMS10001
  1. ; ------------------------
  1. ; 819_1. Display prepayments not assigned to a batch (^BARCLU)
  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)
  1. ; 819_5. Allow user to assign prepayment to batch (^BARCLU,^BARCLU01,^BARPUTL,^BARPST1,^BARBLLK)
  1. ; 819_6. Print Prepayment Receipt (^BARPPY02) (new routine)
  1. ; ********************************************************************* ;
  1. ;
  1. S ;
  1. CACC ; EP
  1. ; CHeck or Cash entry
  1. ;S DR=DR_"101;" ;amt ;IHS/SD/SDR bar*1.8*4 SCR88
  1. ;---BEGIN ADD(1)--- ;M819*ADD*TMM*20100710 (M819_5)
  1. ; 29 = Batch Amount (^BARCOL(DUZ(2),BARCLDA,0))
  1. ; 22 = ASK TREASURY DEPOSIT NUMBER (BARCLID(22,"I"))
  1. ;S DR=DR_"101"_$S((+$P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,29)=0&+BARCLID(22,"I")):"////0;",1:";") ;101=credit ;IHS/SD/SDR bar*1.8*4 SCR88 ;M819*DEL*TMM*20100710 (819_5)
  1. ;
  1. ;User should not be prompted for CREDIT when Prepayment item selected.
  1. ;Prepayment amt defaults to CREDIT.
  1. I '$G(BARPPSEL) S DR=DR_"101"_$S((+$P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,29)=0&+BARCLID(22,"I")):"////0;",1:";") ;101=credit ;IHS/SD/SDR bar*1.8*4 SCR88 ;M819*ADD*TMM*20100710 (819_5)
  1. I $G(BARPPSEL) D
  1. . S BARPPCR=$G(BARPPAY(.07))
  1. . S DR=DR_"101////^S X=$G(BARPPAY(.07));"
  1. . W !,"CREDIT: ",$G(BARPPAY(.07))
  1. ;-------------------------------------------------------------------
  1. ;look up A/R BILL-PATIENT-DOS
  1. ;I BARX=52 S:+BARCLID(15,"I") DR=DR_"6///^S X="""" D ^BARBLLK S:$D(BARBL)>1 X=BARBL(.01);Q;" ;bill CA ;M819*DEL*TMM*20100711
  1. ;I BARX=53 S:+BARCLID(14,"I") DR=DR_"6///^S X="""" D ^BARBLLK S:$D(BARBL)>1 X=BARBL(.01);Q;" ;bill CC ;M819*DEL*TMM*20100711
  1. ;I BARX=81 S:+BARCLID(16,"I") DR=DR_"6///^S X="""" D ^BARBLLK S:$D(BARBL)>1 X=BARBL(.01);Q;" ;bill CK ;M819*DEL*TMM*20100711
  1. I '$G(BARPPSEL) D
  1. . I BARX=52 S:+BARCLID(15,"I") DR=DR_"6///^S X="""" D ^BARBLLK S:$D(BARBL)>1 X=BARBL(.01);Q;" ;bill CA
  1. . I BARX=53 S:+BARCLID(14,"I") DR=DR_"6///^S X="""" D ^BARBLLK S:$D(BARBL)>1 X=BARBL(.01);Q;" ;bill CC
  1. . I BARX=81 S:+BARCLID(16,"I") DR=DR_"6///^S X="""" D ^BARBLLK S:$D(BARBL)>1 X=BARBL(.01);Q;" ;bill CK
  1. ;
  1. I $G(BARPPSEL) D
  1. . ; Prepayment patient
  1. . S BARPPNM=BARPPAY(.08) ; A/R Bill Patient name from Prepayment file
  1. . ; Prepayment A/R BILL NUMBER
  1. . ;M819*DEL*TMM*20100727 S BARPPBL=BARPPAY(.09) ; A/R BILL IEN from Prepayment file
  1. . S BARPPBL=BARPPAY(.09,"I") ; A/R BILL IEN from Prepayment file ;M819*ADD*TMM*20100727
  1. . ; Prepayment A/R BILL DOS
  1. . S BARPPBDS=BARPPAY(.12)
  1. . ; Prepayment DOS
  1. . S BARPPSDT=BARPPAY(.13)
  1. . ;
  1. . ;M819*DEL*TMM*20100726 S DICB=BARPPNM ;default lookup - Patient Name
  1. . S DICB=$$GET1^DIQ(90050.01,BARPPBL_",",101,"I") ;default lookup - Patient Name
  1. . S DICB2=BARPPBL ;default lookup for A/R Bill
  1. . S DICB3=BARPPBDS ;default lookup for A/R BILL DOS ;M819*ADD*TMM*20100715
  1. . I BARX=52 S:+BARCLID(15,"I") DR=DR_"6///^S X="""" D EN1^BARBLLK(DICB,DICB2,DICB3) S:$D(BARBL)>1 X=BARBL(.01);Q;" ;bill CA
  1. . I BARX=53 S:+BARCLID(14,"I") DR=DR_"6///^S X="""" D EN1^BARBLLK(DICB,DICB2,DICB3) S:$D(BARBL)>1 X=BARBL(.01);Q;" ;bill CC
  1. . I BARX=81 S:+BARCLID(16,"I") DR=DR_"6///^S X="""" D EN1^BARBLLK(DICB,DICB2,DICB3) S:$D(BARBL)>1 X=BARBL(.01);Q;" ;bill CK
  1. W !!
  1. ;-----END ADD(1)--- ;M819*ADD*TMM*20100710 (M819_5)
  1. K BARBL
  1. S DIDEL=90050
  1. S D0=$G(BARCLDA),D1=$G(BARITDA) ;;PARAMS FOR COLL BATCH ITEMS FIELD 20 OUTPUT TRANSFORM - IHS/DIT/CPC - BAR*1.8*28 CR5994
  1. D ^DIE
  1. W !!!!
  1. S DR=""
  1. I '$D(BARBL) D
  1. .I BARX=52 S:+BARCLID(18,"I") DR=DR_"5;" ;pat CA ;5=Patient
  1. .I BARX=53 S:+BARCLID(17,"I") DR=DR_"5;" ;pat CC
  1. .I BARX=81 S:+BARCLID(19,"I") DR=DR_"5;" ;pat CK
  1. .S DR=DR_"7//^S X=$G(BARITAC);" ;account
  1. .I BARSPAR(2,"I") S DR=DR_"8//^S X=$G(BARITLC);" ;8=Visit Location (A/R Satelite)
  1. .E S DR=DR_"8///^S X=BARSPAR(.01);" ;location
  1. I BARCLIT(201)]"" S DR=DR_"201///^S X=BARCLIT(201);Q;" ;201=payor
  1. S DR=DR_"201;" ;payor
  1. S:+BARCLID(13,"I") DR=DR_"10;" ;i/o pat
  1. ;S DR=DR_"16//^S X=BARCLID(3);301;" ;receipt,comment ;16=AUTO PRINT RECEIPT ;M819*DEL*TMM*20100710 (M819_2)
  1. S DR=DR_"301;" ;comment bar*1.8*22 HEAT46421
  1. ;IHS/SD/TPF BAR*1.8*3 UFMS
  1. I +BARCLID(22,"I") D
  1. .Q:BARX'=81&(BARX'=53)&(BARX'=52)&(BARX'=99)
  1. .;S DR=DR_"20R;" ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1. .S DR=DR_"20////"_$P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)_";" ;20=TDN/IPAC ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1. ;END BAR*1.8*3 UFMS
  1. S D0=$G(BARCLDA),D1=$G(BARITDA) ;;PARAMS FOR COLL BATCH ITEMS FIELD 20 OUTPUT TRANSFORM - IHS/DIT/CPC - BAR*1.8*28 CR5994
  1. S DIDEL=90050
  1. D ^DIE
  1. W !!!!
  1. K DIDEL
  1. K DICB,DICB2,DICB3,DIC("B") ;M819*ADD*TMM*20100713
  1. ;insert sub node
  1. D INSSUB^BARCLU0 ;insert sub node
  1. CACCE ;
  1. Q