BARCLU01 ; IHS/SD/LSL - Split out of BARCLU0 ;; 07/09/2010
;;1.8;IHS ACCOUNTS RECEIVABLE;**3,4,19,22,28**;OCT 26, 2005;Build 92
;;
; IHS/SD/TMM 06/18/2010 1.8*Patch 19 (M819), Add Prepayment functionality.
; See work order 3PMS10001
; ------------------------
; 819_1. Display prepayments not assigned to a batch (^BARCLU)
; 819_2. Remove prompt: AUTO PRINT RECEIPT (^BARCLU01)
; 819_3. Prepayment entry ^BARPPY01 (new routine),^BARCLU1,^BARPUTL
; 819_4. Display prepayments matching payment type selected (^BARCLU)
; 819_5. Allow user to assign prepayment to batch (^BARCLU,^BARCLU01,^BARPUTL,^BARPST1,^BARBLLK)
; 819_6. Print Prepayment Receipt (^BARPPY02) (new routine)
; ********************************************************************* ;
;
S ;
CACC ; EP
; CHeck or Cash entry
;S DR=DR_"101;" ;amt ;IHS/SD/SDR bar*1.8*4 SCR88
;---BEGIN ADD(1)--- ;M819*ADD*TMM*20100710 (M819_5)
; 29 = Batch Amount (^BARCOL(DUZ(2),BARCLDA,0))
; 22 = ASK TREASURY DEPOSIT NUMBER (BARCLID(22,"I"))
;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)
;
;User should not be prompted for CREDIT when Prepayment item selected.
;Prepayment amt defaults to CREDIT.
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)
I $G(BARPPSEL) D
. S BARPPCR=$G(BARPPAY(.07))
. S DR=DR_"101////^S X=$G(BARPPAY(.07));"
. W !,"CREDIT: ",$G(BARPPAY(.07))
;-------------------------------------------------------------------
;look up A/R BILL-PATIENT-DOS
;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
;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
;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
I '$G(BARPPSEL) D
. I BARX=52 S:+BARCLID(15,"I") DR=DR_"6///^S X="""" D ^BARBLLK S:$D(BARBL)>1 X=BARBL(.01);Q;" ;bill CA
. I BARX=53 S:+BARCLID(14,"I") DR=DR_"6///^S X="""" D ^BARBLLK S:$D(BARBL)>1 X=BARBL(.01);Q;" ;bill CC
. I BARX=81 S:+BARCLID(16,"I") DR=DR_"6///^S X="""" D ^BARBLLK S:$D(BARBL)>1 X=BARBL(.01);Q;" ;bill CK
;
I $G(BARPPSEL) D
. ; Prepayment patient
. S BARPPNM=BARPPAY(.08) ; A/R Bill Patient name from Prepayment file
. ; Prepayment A/R BILL NUMBER
. ;M819*DEL*TMM*20100727 S BARPPBL=BARPPAY(.09) ; A/R BILL IEN from Prepayment file
. S BARPPBL=BARPPAY(.09,"I") ; A/R BILL IEN from Prepayment file ;M819*ADD*TMM*20100727
. ; Prepayment A/R BILL DOS
. S BARPPBDS=BARPPAY(.12)
. ; Prepayment DOS
. S BARPPSDT=BARPPAY(.13)
. ;
. ;M819*DEL*TMM*20100726 S DICB=BARPPNM ;default lookup - Patient Name
. S DICB=$$GET1^DIQ(90050.01,BARPPBL_",",101,"I") ;default lookup - Patient Name
. S DICB2=BARPPBL ;default lookup for A/R Bill
. S DICB3=BARPPBDS ;default lookup for A/R BILL DOS ;M819*ADD*TMM*20100715
. 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
. 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
. 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
W !!
;-----END ADD(1)--- ;M819*ADD*TMM*20100710 (M819_5)
K BARBL
S DIDEL=90050
S D0=$G(BARCLDA),D1=$G(BARITDA) ;;PARAMS FOR COLL BATCH ITEMS FIELD 20 OUTPUT TRANSFORM - IHS/DIT/CPC - BAR*1.8*28 CR5994
D ^DIE
W !!!!
S DR=""
I '$D(BARBL) D
.I BARX=52 S:+BARCLID(18,"I") DR=DR_"5;" ;pat CA ;5=Patient
.I BARX=53 S:+BARCLID(17,"I") DR=DR_"5;" ;pat CC
.I BARX=81 S:+BARCLID(19,"I") DR=DR_"5;" ;pat CK
.S DR=DR_"7//^S X=$G(BARITAC);" ;account
.I BARSPAR(2,"I") S DR=DR_"8//^S X=$G(BARITLC);" ;8=Visit Location (A/R Satelite)
.E S DR=DR_"8///^S X=BARSPAR(.01);" ;location
I BARCLIT(201)]"" S DR=DR_"201///^S X=BARCLIT(201);Q;" ;201=payor
S DR=DR_"201;" ;payor
S:+BARCLID(13,"I") DR=DR_"10;" ;i/o pat
;S DR=DR_"16//^S X=BARCLID(3);301;" ;receipt,comment ;16=AUTO PRINT RECEIPT ;M819*DEL*TMM*20100710 (M819_2)
S DR=DR_"301;" ;comment bar*1.8*22 HEAT46421
;IHS/SD/TPF BAR*1.8*3 UFMS
I +BARCLID(22,"I") D
.Q:BARX'=81&(BARX'=53)&(BARX'=52)&(BARX'=99)
.;S DR=DR_"20R;" ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.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
;END BAR*1.8*3 UFMS
S D0=$G(BARCLDA),D1=$G(BARITDA) ;;PARAMS FOR COLL BATCH ITEMS FIELD 20 OUTPUT TRANSFORM - IHS/DIT/CPC - BAR*1.8*28 CR5994
S DIDEL=90050
D ^DIE
W !!!!
K DIDEL
K DICB,DICB2,DICB3,DIC("B") ;M819*ADD*TMM*20100713
;insert sub node
D INSSUB^BARCLU0 ;insert sub node
CACCE ;
Q
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
+2 ;;
+3 ; IHS/SD/TMM 06/18/2010 1.8*Patch 19 (M819), Add Prepayment functionality.
+4 ; See work order 3PMS10001
+5 ; ------------------------
+6 ; 819_1. Display prepayments not assigned to a batch (^BARCLU)
+7 ; 819_2. Remove prompt: AUTO PRINT RECEIPT (^BARCLU01)
+8 ; 819_3. Prepayment entry ^BARPPY01 (new routine),^BARCLU1,^BARPUTL
+9 ; 819_4. Display prepayments matching payment type selected (^BARCLU)
+10 ; 819_5. Allow user to assign prepayment to batch (^BARCLU,^BARCLU01,^BARPUTL,^BARPST1,^BARBLLK)
+11 ; 819_6. Print Prepayment Receipt (^BARPPY02) (new routine)
+12 ; ********************************************************************* ;
+13 ;
S ;
CACC ; EP
+1 ; CHeck or Cash entry
+2 ;S DR=DR_"101;" ;amt ;IHS/SD/SDR bar*1.8*4 SCR88
+3 ;---BEGIN ADD(1)--- ;M819*ADD*TMM*20100710 (M819_5)
+4 ; 29 = Batch Amount (^BARCOL(DUZ(2),BARCLDA,0))
+5 ; 22 = ASK TREASURY DEPOSIT NUMBER (BARCLID(22,"I"))
+6 ;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)
+7 ;
+8 ;User should not be prompted for CREDIT when Prepayment item selected.
+9 ;Prepayment amt defaults to CREDIT.
+10 ;101=credit ;IHS/SD/SDR bar*1.8*4 SCR88 ;M819*ADD*TMM*20100710 (819_5)
IF '$GET(BARPPSEL)
SET DR=DR_"101"_$SELECT((+$PIECE($GET(^BARCOL(DUZ(2),BARCLDA,0)),U,29)=0&+BARCLID(22,"I")):"////0;",1:";")
+11 IF $GET(BARPPSEL)
Begin DoDot:1
+12 SET BARPPCR=$GET(BARPPAY(.07))
+13 SET DR=DR_"101////^S X=$G(BARPPAY(.07));"
+14 WRITE !,"CREDIT: ",$GET(BARPPAY(.07))
End DoDot:1
+15 ;-------------------------------------------------------------------
+16 ;look up A/R BILL-PATIENT-DOS
+17 ;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
+18 ;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
+19 ;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
+20 IF '$GET(BARPPSEL)
Begin DoDot:1
+21 ;bill CA
IF BARX=52
IF +BARCLID(15,"I")
SET DR=DR_"6///^S X="""" D ^BARBLLK S:$D(BARBL)>1 X=BARBL(.01);Q;"
+22 ;bill CC
IF BARX=53
IF +BARCLID(14,"I")
SET DR=DR_"6///^S X="""" D ^BARBLLK S:$D(BARBL)>1 X=BARBL(.01);Q;"
+23 ;bill CK
IF BARX=81
IF +BARCLID(16,"I")
SET DR=DR_"6///^S X="""" D ^BARBLLK S:$D(BARBL)>1 X=BARBL(.01);Q;"
End DoDot:1
+24 ;
+25 IF $GET(BARPPSEL)
Begin DoDot:1
+26 ; Prepayment patient
+27 ; A/R Bill Patient name from Prepayment file
SET BARPPNM=BARPPAY(.08)
+28 ; Prepayment A/R BILL NUMBER
+29 ;M819*DEL*TMM*20100727 S BARPPBL=BARPPAY(.09) ; A/R BILL IEN from Prepayment file
+30 ; A/R BILL IEN from Prepayment file ;M819*ADD*TMM*20100727
SET BARPPBL=BARPPAY(.09,"I")
+31 ; Prepayment A/R BILL DOS
+32 SET BARPPBDS=BARPPAY(.12)
+33 ; Prepayment DOS
+34 SET BARPPSDT=BARPPAY(.13)
+35 ;
+36 ;M819*DEL*TMM*20100726 S DICB=BARPPNM ;default lookup - Patient Name
+37 ;default lookup - Patient Name
SET DICB=$$GET1^DIQ(90050.01,BARPPBL_",",101,"I")
+38 ;default lookup for A/R Bill
SET DICB2=BARPPBL
+39 ;default lookup for A/R BILL DOS ;M819*ADD*TMM*20100715
SET DICB3=BARPPBDS
+40 ;bill CA
IF BARX=52
IF +BARCLID(15,"I")
SET DR=DR_"6///^S X="""" D EN1^BARBLLK(DICB,DICB2,DICB3) S:$D(BARBL)>1 X=BARBL(.01);Q;"
+41 ;bill CC
IF BARX=53
IF +BARCLID(14,"I")
SET DR=DR_"6///^S X="""" D EN1^BARBLLK(DICB,DICB2,DICB3) S:$D(BARBL)>1 X=BARBL(.01);Q;"
+42 ;bill CK
IF BARX=81
IF +BARCLID(16,"I")
SET DR=DR_"6///^S X="""" D EN1^BARBLLK(DICB,DICB2,DICB3) S:$D(BARBL)>1 X=BARBL(.01);Q;"
End DoDot:1
+43 WRITE !!
+44 ;-----END ADD(1)--- ;M819*ADD*TMM*20100710 (M819_5)
+45 KILL BARBL
+46 SET DIDEL=90050
+47 ;;PARAMS FOR COLL BATCH ITEMS FIELD 20 OUTPUT TRANSFORM - IHS/DIT/CPC - BAR*1.8*28 CR5994
SET D0=$GET(BARCLDA)
SET D1=$GET(BARITDA)
+48 DO ^DIE
+49 WRITE !!!!
+50 SET DR=""
+51 IF '$DATA(BARBL)
Begin DoDot:1
+52 ;pat CA ;5=Patient
IF BARX=52
IF +BARCLID(18,"I")
SET DR=DR_"5;"
+53 ;pat CC
IF BARX=53
IF +BARCLID(17,"I")
SET DR=DR_"5;"
+54 ;pat CK
IF BARX=81
IF +BARCLID(19,"I")
SET DR=DR_"5;"
+55 ;account
SET DR=DR_"7//^S X=$G(BARITAC);"
+56 ;8=Visit Location (A/R Satelite)
IF BARSPAR(2,"I")
SET DR=DR_"8//^S X=$G(BARITLC);"
+57 ;location
IF '$TEST
SET DR=DR_"8///^S X=BARSPAR(.01);"
End DoDot:1
+58 ;201=payor
IF BARCLIT(201)]""
SET DR=DR_"201///^S X=BARCLIT(201);Q;"
+59 ;payor
SET DR=DR_"201;"
+60 ;i/o pat
IF +BARCLID(13,"I")
SET DR=DR_"10;"
+61 ;S DR=DR_"16//^S X=BARCLID(3);301;" ;receipt,comment ;16=AUTO PRINT RECEIPT ;M819*DEL*TMM*20100710 (M819_2)
+62 ;comment bar*1.8*22 HEAT46421
SET DR=DR_"301;"
+63 ;IHS/SD/TPF BAR*1.8*3 UFMS
+64 IF +BARCLID(22,"I")
Begin DoDot:1
+65 IF BARX'=81&(BARX'=53)&(BARX'=52)&(BARX'=99)
QUIT
+66 ;S DR=DR_"20R;" ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
+67 ;20=TDN/IPAC ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
SET DR=DR_"20////"_$PIECE($GET(^BARCOL(DUZ(2),BARCLDA,0)),U,28)_";"
End DoDot:1
+68 ;END BAR*1.8*3 UFMS
+69 ;;PARAMS FOR COLL BATCH ITEMS FIELD 20 OUTPUT TRANSFORM - IHS/DIT/CPC - BAR*1.8*28 CR5994
SET D0=$GET(BARCLDA)
SET D1=$GET(BARITDA)
+70 SET DIDEL=90050
+71 DO ^DIE
+72 WRITE !!!!
+73 KILL DIDEL
+74 ;M819*ADD*TMM*20100713
KILL DICB,DICB2,DICB3,DIC("B")
+75 ;insert sub node
+76 ;insert sub node
DO INSSUB^BARCLU0
CACCE ;
+1 QUIT
