- 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