BARPPY1A ; IHS/SD/TMM - PREPAYMENT ENTRY - CONT'D ; 05/11/2010
;;1.8;IHS ACCOUNTS RECEIVABLE;**19**;OCT 26, 2005
;
; IHS/SD/TMM 06/18/10 1.8*19 Add Prepayment functionality.
; *********************************************************************
;
NEW() ;EP - extrensic call to establish a new prepayment record
; returns 0-lock on file, fm-dt/sec -IEN ; -1 not added
F I=1:1:5 L +^BARPPAY(DUZ(2)):2 S X=$T Q:X
I 'X D Q X
. W *7,!!,"A/R PREPAYMENT FILE LOCKED, try again",!!
;---- Create Pre-Payment record
K DIC,DR,DA
S DIC="^BARPPAY(DUZ(2),"
S DIC(0)="E"
K DD,DO
D FILE^DICN
K DR,DA,DIE
L -^BARPPAY(DUZ(2))
Q +Y
;
PAD(BARVAR,BARLNG) ; EP
; BARVAR = data
; BARLNG = length
; Right justify, zero fill value BARVAR for length BARLNG
K BARZERO
S $P(BARZERO,"0",BARLNG+1)=""
S BARVAR=BARZERO_BARVAR
S BARVAR=$E(BARVAR,$L(BARVAR)-(BARLNG-1),$L(BARVAR))
Q BARVAR
;
CARDTYPE(CARD) ;
S CARDTYPE=$S(CARD="A":"AMERICAN EXPRESS",CARD="C":"DINERS CLUB",CARD="D":"DISCOVER",CARD="M":"MASTERCARD",CARD="V":"VISA",1:"")
Q CARDTYPE
;
PAYTYPE(PMTYP) ;
S PAYTYPE=$S(PMTYP="CA":"CASH",PMTYP="CK":"CHECK",PMTYP="CC":"CREDIT CARD",PMTYP="DB":"DEBIT CARD",1:"")
Q PAYTYPE
;
CKOUT() ; Check DIR values
I $D(DTOUT)!$D(DUOUT)!$D(DIROUT)!$G(BARSTOP) Q 1
Q 0
;
; *********************************************************************
HINPTON ; Hilight when PT NAME field
I $G(BARPAT)'="",BARPAT'=BARPTI1 D
. W $$EN^BARVDF("HIN")
. S HINPTON=1
Q
;
HINPTOFF ; Turn off Hilight when PT NAME field
W $$EN^BARVDF("HIF")
S HINPTON=0
Q
;
HINBLON ; Hilight DOS fields
I BARDOSB'="",BARDOSB'=BARPDOS D
. W $$EN^BARVDF("HIN")
. S HINBLON=1
Q
;
HINBLOFF ; Turn off hilight for DOS fields
W "**",$$EN^BARVDF("HIF")
S HINBLON=0
Q
;
RECAP ; Display data for user to review and select next step
Q:BARSTOP
W $$EN^BARVDF("IOF"),! ;Form Feed/Clear screen
W $$EN^BARVDF("CLR") ;Clear screen
S Y=BARPDOS
D D^DIQ ;get external date
D HINBLON
W !,"1)",?4,"PAYMENT FOR DOS:",?22,Y
I HINBLON D HINBLOFF
W !,"2)",?4,"CREDIT: ",?22,"$",$FN(BARAMT,",",2)
W !!,"3)",?4,"DEPARTMENT:",?22,BARDEPTE
I BARPMTYP="CA" S BARTMP="CASH^^"
I BARPMTYP="CK" S BARTMP="CHECK^CHECK NUMBER:^NAME ON CK ACCOUNT:"
I BARPMTYP="CC" S BARTMP="CREDIT CARD^CARD TYPE:^NAME ON CARD:"
I BARPMTYP="DB" S BARTMP="DEBIT CARD^CARD TYPE:^NAME ON CARD:"
W !!,"4)",?4,"PAYMENT TYPE:",?22,$P(BARTMP,U) ;PAYMENT TYPE line 1
S BARTMP1=$S(BARPMTYP="CK":BARCK,BARPMTYP="CC":BARCTYPN,BARPMTYP="DB":BARCTYPN,1:"")
I $P(BARTMP,U)'="CASH" D
. W !,?4,$P(BARTMP,U,2),?22,BARTMP1 ;PAYMENT TYPE line 2
. S BARTMP1=$S("^CK^CC^DB^"[BARPMTYP:BARCNAME,1:"")
. W !,?4,$P(BARTMP,U,3),?22,BARTMP1 ;PAYMENT TYPE line 3
W !!,"5)",?4,"A/R BILL NUMBER:",?22,$$GET1^DIQ(90050.01,BARBLIEN_",",.01,"E")
I BARBLIEN'="" D HINPTON ;hilight patient name when applicable
W !,?4,"PATIENT NAME:",?22,$S(+BARPAT:$P(^DPT(BARPAT,0),U),1:"")
I HINPTON D HINPTOFF ;hilight patient name when applicable
I BARBLIEN'="" D HINBLON
S Y=$G(BARDOSB)
D D^DIQ ;converts internal FM date to external
W !,?4,"BILL DOS:",?22,Y
I HINBLON D HINBLOFF
D HINPTON
W !!,"6)",?4,"PATIENT:",?22,BARPTNM1
I HINPTON D HINPTOFF
CMT ;Comments
K BARCMT ; comments array
S BARCMT=$L(BARCMTS)
N SP,W,L,WORD S SP=" ",L=1 ;SP-space; W- WordCtr; L-LINE#
S BARCMT(1)=""
F W=1:1 S WORD=$P(BARCMTS,SP,W) Q:WORD="" D
. I W>1 S WORD=SP_WORD ; space betw words
. I ($L(BARCMT(L))+$L(WORD))'>70 S BARCMT(L)=BARCMT(L)_WORD
. E S L=L+1,BARCMT(L)=$E(WORD,2,99) ; remove leading space
I BARCMT(1)="" K BARCMT
W !!,"7)",?4,"COMMENTS:"
F I=1:1:4 S BARCMT=$O(BARCMT(I)) Q:$G(BARCMT(I))="" D
. S BARCMT(5)=BARCMT(I)
. I BARCMT(I)=1 W " "
. E I $E(BARCMT(5),$L(BARCMT(5)))'=" "&($E(BARCMT(I))'=" ") W " "
. W BARCMT(I)
K BARCMT(5)
;
FMQ ; Prompt F/M/Q
I $G(BARDOSB)'="",BARDOSB'=BARPDOS W !!,?4,$$EN^BARVDF("HIN"),BARNOTE1,$$EN^BARVDF("HIF")
I $G(BARPAT)'="",BARPAT'=BARPTI1 W $$EN^BARVDF("HIN"),!!,?4,BARNOTE2,$$EN^BARVDF("HIF")
S BARFILE=""
W !!
D RESETDIR^BARPPY01
S DIR(0)="SA^F:FILE;M:MODIFY;Q:QUIT"
S DIR("A")="FILE PREPAYMENT? SELECT (F)ILE, (M)ODIFY, (Q)UIT: "
K DA
D ^DIR
I $D(DUOUT)!$D(DIROUT) G FMQ
I $D(DTOUT) Q
S BARFILE=X
;
; ---FILE---
I "Ff"[BARFILE D
. S BARTMPF="OK" ;OK to file (No A/R Bill Selected, or A/R Bill selected and matches item 6 PATIENT)
. I +$G(BARPTI1)=0,(+$G(BARBLIEN)=0) S BARTMPF="NOB" ;bar*1.8*19 SDR
. I $G(BARPAT)'="",BARPAT'=BARPTI1 S BARTMPF="NOK" ;A/R Bill selected and does not match item 6 PATIENT)
;start new code bar*1.8*19 SDR
I "Ff"[BARFILE,($G(BARTMPF)="NOB") D G RECAP
.W !!,"A PATIENT or a BILL NUMBER is required!" H 1
;end new SDR
I "Ff"[BARFILE,BARTMPF="NOK" D
. W !!
. S DIR("A",1)="Patient in Item 5 does not match Patient in Item 6"
. S DIR("A",2)="Do you still want to file this data?"
. S DIR("A",3)=" Enter 'YES' to File data"
. S DIR("A",4)=" Enter 'NO' to Modify data"
. S DIR("A",5)=" "
. S DIR("A")= "Enter YES/NO: "
. S DIR("B")="NO"
. S DIR(0)="YA"
. D ^DIR
. I Y=1 S BARTMPF="OK" Q
I "Ff"[BARFILE,BARTMPF="OK" Q
I "Ff"[BARFILE,BARTMPF="NOK" G RECAP
I "Qq"[BARFILE,Y=1 S BARQUIT=1 Q
I "Qq"[BARFILE,Y=0 G FMQ
;
I "Qq"[BARFILE D
. W !!
. S DIR("A",1)="Are you sure you want to quit?"
. S DIR("A",2)="The data you have entered will not be saved."
. S DIR("A")="Proceed with quit? YES/NO "
. S DIR("B")="NO"
. S DIR(0)="YA"
. D ^DIR
I "Qq"[BARFILE,Y=1 S BARQUIT=1 Q ;M819*ADD*TMM*20100826
I "Qq"[BARFILE,Y=0 G FMQ
S BARDONE=0
F I=1:1 D Q:BARDONE
. S BARUPDT=1
. D UPDT
. S BARUPDT=0
Q
;
FILE ;File prepayment
; Get new IEN for ^BARPPAY
S BARPPIEN=$$NEW^BARPPY1A()
FDATA ; Add Pre-Payment data
K DIE,DR,DA
; Receipt #
I '$D(BARPSAT(DUZ(2),2)) D BARPSAT^BARUTL0
S BARSUFX=$G(BARPSAT(DUZ(2),2))
S BARCPT=BARSUFX_$$PAD^BARPPY1A(BARPPIEN,10)
S DR=".01////^S X=BARCPT"
; Other data
D NOW^%DTC
S BARPDOSE=$P(%,".")
S DR=DR_";.02////^S X=BARPDOSE" ;PAYMENT DATE
S DR=DR_";.03////^S X=BARPMTYP" ;PAYMENT TYPE
S DR=DR_";.04////^S X=$G(BARCK)" ;CHECK #
S DR=DR_";.05////^S X=$G(BARCNAME)" ;BANK ACCOUNT OWNER NAME
S DR=DR_";.06////^S X=$G(BARCTYPE)" ;CARD TYPE
S DR=DR_";.07////^S X=$G(BARAMT)" ;CREDIT
S DR=DR_";.08////^S X=$G(BARPTI1)" ;PATIENT (IEN) (selected patient, not A/R BILL patient)
S DR=DR_";.09////^S X=$G(BARBLIEN)" ;A/R BILL
S DR=DR_";.1////^S X=DUZ" ;ENTERED BY
S DR=DR_";.11////^S X=BARDEPTI" ;DEPARTMENT
S DR=DR_";.12////^S X=$G(BARDOSB)" ;BILL DOS
S DR=DR_";.13////^S X=BARPDOS" ;PAYMENT FOR DOS
S DR=DR_";.18////^S X=""N""" ;BATCH FLAG
; Add to Pre-Payment file
S DA=BARPPIEN
S DIE=$$DIC^XBDIQ1(90050.06)
D ^DIE
CMTFILE ;EP
S BARIENS=BARPPIEN_","
D WP^DIE(90050.06,BARIENS,101,"","BARCMT","MSG")
D WP^DIE(90050.06,BARIENS,.2,"","BARCMT","MSG")
W !!!,?9,"RECEIPT #:",?22,BARCPT
Q
;
UPDT ; Allow user to modify data entered
Q:BARSTOP
S (BARITEM,BARLIST)=""
W !!
D RESETDIR^BARPPY01
S BARLIST="SAO^1:PAYMENT FOR DOS;2:CREDIT;3:DEPARTMENT"
S BARLIST=BARLIST_";4:PAYMENT TYPE INFO"
S BARLIST=BARLIST_";5:A/R BILL INFO"
S BARLIST=BARLIST_";6:PATIENT"
S BARLIST=BARLIST_";7:COMMENTS"
S DIR(0)=BARLIST
S DIR("A")="SELECT ITEM TO MODIFY: (?? for list) "
K DA
D ^DIR
I $D(DIROUT) S BARSTOP=1 Q
I $D(DTOUT)!$D(DUOUT) S BARDONE=1 Q
K DIRUT
S BARITEM=X
I BARITEM=1 F I=1:1 D Q:(+BARPDOS)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT)!(BARSTOP)
. ; Get DOS for this payment
. S BARPDOS=""
. D PAYDOS1^BARPPY01
. I $D(DIROUT) S BARSTOP=1
I BARITEM=2 F I=1:1 D Q:(+BARAMT>0)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT)!(BARSTOP)
. ; Enter Credit amount
. D AMOUNT1^BARPPY01
. I $D(DIROUT) S BARSTOP=1
I BARITEM=3 F I=1:1 D Q:(BARDEPTI'="")!$D(DTOUT)!($D(DUOUT))!$D(DIROUT)!(BARSTOP)
. D SELDEPT^BARPPY01
. I $D(DIROUT) S BARSTOP=1
I BARITEM=4 F I=1:1 D Q:($G(BARDAT))!$D(DTOUT)!($D(DUOUT))!$D(DIROUT)!(BARSTOP)
. S BARDAT=0 ;required data collected flag
. D SELPMT^BARPPY01
. I $D(DIROUT) S BARSTOP=1
I BARITEM=5 F I=1:1 D Q:($D(BARFPASS))!$D(DTOUT)!$D(DUOUT)!$D(DIROUT)!(BARSTOP)
. ; Get A/R Bill, Patient, A/R Bill DOS
. K BARFPASS
. D ARBILL1^BARPPY01
. I $D(DIROUT) S BARSTOP=1
I BARITEM=6 F I=1:1 D Q:($D(BARPTNM1))!$D(DTOUT)!$D(DUOUT)!$D(DIROUT)!(BARSTOP)
. ; Get Patient Name
. D GETPAT1^BARPPY01
. I $D(DIROUT) S BARSTOP=1
I BARITEM=7 D CMTS^BARPPY01
D RECAP
S BARDONE=1
Q
BARPPY1A ; IHS/SD/TMM - PREPAYMENT ENTRY - CONT'D ; 05/11/2010
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**19**;OCT 26, 2005
+2 ;
+3 ; IHS/SD/TMM 06/18/10 1.8*19 Add Prepayment functionality.
+4 ; *********************************************************************
+5 ;
NEW() ;EP - extrensic call to establish a new prepayment record
+1 ; returns 0-lock on file, fm-dt/sec -IEN ; -1 not added
+2 FOR I=1:1:5
LOCK +^BARPPAY(DUZ(2)):2
SET X=$TEST
IF X
QUIT
+3 IF 'X
Begin DoDot:1
+4 WRITE *7,!!,"A/R PREPAYMENT FILE LOCKED, try again",!!
End DoDot:1
QUIT X
+5 ;---- Create Pre-Payment record
+6 KILL DIC,DR,DA
+7 SET DIC="^BARPPAY(DUZ(2),"
+8 SET DIC(0)="E"
+9 KILL DD,DO
+10 DO FILE^DICN
+11 KILL DR,DA,DIE
+12 LOCK -^BARPPAY(DUZ(2))
+13 QUIT +Y
+14 ;
PAD(BARVAR,BARLNG) ; EP
+1 ; BARVAR = data
+2 ; BARLNG = length
+3 ; Right justify, zero fill value BARVAR for length BARLNG
+4 KILL BARZERO
+5 SET $PIECE(BARZERO,"0",BARLNG+1)=""
+6 SET BARVAR=BARZERO_BARVAR
+7 SET BARVAR=$EXTRACT(BARVAR,$LENGTH(BARVAR)-(BARLNG-1),$LENGTH(BARVAR))
+8 QUIT BARVAR
+9 ;
CARDTYPE(CARD) ;
+1 SET CARDTYPE=$SELECT(CARD="A":"AMERICAN EXPRESS",CARD="C":"DINERS CLUB",CARD="D":"DISCOVER",CARD="M":"MASTERCARD",CARD="V":"VISA",1:"")
+2 QUIT CARDTYPE
+3 ;
PAYTYPE(PMTYP) ;
+1 SET PAYTYPE=$SELECT(PMTYP="CA":"CASH",PMTYP="CK":"CHECK",PMTYP="CC":"CREDIT CARD",PMTYP="DB":"DEBIT CARD",1:"")
+2 QUIT PAYTYPE
+3 ;
CKOUT() ; Check DIR values
+1 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)!$GET(BARSTOP)
QUIT 1
+2 QUIT 0
+3 ;
+4 ; *********************************************************************
HINPTON ; Hilight when PT NAME field
+1 IF $GET(BARPAT)'=""
IF BARPAT'=BARPTI1
Begin DoDot:1
+2 WRITE $$EN^BARVDF("HIN")
+3 SET HINPTON=1
End DoDot:1
+4 QUIT
+5 ;
HINPTOFF ; Turn off Hilight when PT NAME field
+1 WRITE $$EN^BARVDF("HIF")
+2 SET HINPTON=0
+3 QUIT
+4 ;
HINBLON ; Hilight DOS fields
+1 IF BARDOSB'=""
IF BARDOSB'=BARPDOS
Begin DoDot:1
+2 WRITE $$EN^BARVDF("HIN")
+3 SET HINBLON=1
End DoDot:1
+4 QUIT
+5 ;
HINBLOFF ; Turn off hilight for DOS fields
+1 WRITE "**",$$EN^BARVDF("HIF")
+2 SET HINBLON=0
+3 QUIT
+4 ;
RECAP ; Display data for user to review and select next step
+1 IF BARSTOP
QUIT
+2 ;Form Feed/Clear screen
WRITE $$EN^BARVDF("IOF"),!
+3 ;Clear screen
WRITE $$EN^BARVDF("CLR")
+4 SET Y=BARPDOS
+5 ;get external date
DO D^DIQ
+6 DO HINBLON
+7 WRITE !,"1)",?4,"PAYMENT FOR DOS:",?22,Y
+8 IF HINBLON
DO HINBLOFF
+9 WRITE !,"2)",?4,"CREDIT: ",?22,"$",$FNUMBER(BARAMT,",",2)
+10 WRITE !!,"3)",?4,"DEPARTMENT:",?22,BARDEPTE
+11 IF BARPMTYP="CA"
SET BARTMP="CASH^^"
+12 IF BARPMTYP="CK"
SET BARTMP="CHECK^CHECK NUMBER:^NAME ON CK ACCOUNT:"
+13 IF BARPMTYP="CC"
SET BARTMP="CREDIT CARD^CARD TYPE:^NAME ON CARD:"
+14 IF BARPMTYP="DB"
SET BARTMP="DEBIT CARD^CARD TYPE:^NAME ON CARD:"
+15 ;PAYMENT TYPE line 1
WRITE !!,"4)",?4,"PAYMENT TYPE:",?22,$PIECE(BARTMP,U)
+16 SET BARTMP1=$SELECT(BARPMTYP="CK":BARCK,BARPMTYP="CC":BARCTYPN,BARPMTYP="DB":BARCTYPN,1:"")
+17 IF $PIECE(BARTMP,U)'="CASH"
Begin DoDot:1
+18 ;PAYMENT TYPE line 2
WRITE !,?4,$PIECE(BARTMP,U,2),?22,BARTMP1
+19 SET BARTMP1=$SELECT("^CK^CC^DB^"[BARPMTYP:BARCNAME,1:"")
+20 ;PAYMENT TYPE line 3
WRITE !,?4,$PIECE(BARTMP,U,3),?22,BARTMP1
End DoDot:1
+21 WRITE !!,"5)",?4,"A/R BILL NUMBER:",?22,$$GET1^DIQ(90050.01,BARBLIEN_",",.01,"E")
+22 ;hilight patient name when applicable
IF BARBLIEN'=""
DO HINPTON
+23 WRITE !,?4,"PATIENT NAME:",?22,$SELECT(+BARPAT:$PIECE(^DPT(BARPAT,0),U),1:"")
+24 ;hilight patient name when applicable
IF HINPTON
DO HINPTOFF
+25 IF BARBLIEN'=""
DO HINBLON
+26 SET Y=$GET(BARDOSB)
+27 ;converts internal FM date to external
DO D^DIQ
+28 WRITE !,?4,"BILL DOS:",?22,Y
+29 IF HINBLON
DO HINBLOFF
+30 DO HINPTON
+31 WRITE !!,"6)",?4,"PATIENT:",?22,BARPTNM1
+32 IF HINPTON
DO HINPTOFF
CMT ;Comments
+1 ; comments array
KILL BARCMT
+2 SET BARCMT=$LENGTH(BARCMTS)
+3 ;SP-space; W- WordCtr; L-LINE#
NEW SP,W,L,WORD
SET SP=" "
SET L=1
+4 SET BARCMT(1)=""
+5 FOR W=1:1
SET WORD=$PIECE(BARCMTS,SP,W)
IF WORD=""
QUIT
Begin DoDot:1
+6 ; space betw words
IF W>1
SET WORD=SP_WORD
+7 IF ($LENGTH(BARCMT(L))+$LENGTH(WORD))'>70
SET BARCMT(L)=BARCMT(L)_WORD
+8 ; remove leading space
IF '$TEST
SET L=L+1
SET BARCMT(L)=$EXTRACT(WORD,2,99)
End DoDot:1
+9 IF BARCMT(1)=""
KILL BARCMT
+10 WRITE !!,"7)",?4,"COMMENTS:"
+11 FOR I=1:1:4
SET BARCMT=$ORDER(BARCMT(I))
IF $GET(BARCMT(I))=""
QUIT
Begin DoDot:1
+12 SET BARCMT(5)=BARCMT(I)
+13 IF BARCMT(I)=1
WRITE " "
+14 IF '$TEST
IF $EXTRACT(BARCMT(5),$LENGTH(BARCMT(5)))'=" "&($EXTRACT(BARCMT(I))'=" ")
WRITE " "
+15 WRITE BARCMT(I)
End DoDot:1
+16 KILL BARCMT(5)
+17 ;
FMQ ; Prompt F/M/Q
+1 IF $GET(BARDOSB)'=""
IF BARDOSB'=BARPDOS
WRITE !!,?4,$$EN^BARVDF("HIN"),BARNOTE1,$$EN^BARVDF("HIF")
+2 IF $GET(BARPAT)'=""
IF BARPAT'=BARPTI1
WRITE $$EN^BARVDF("HIN"),!!,?4,BARNOTE2,$$EN^BARVDF("HIF")
+3 SET BARFILE=""
+4 WRITE !!
+5 DO RESETDIR^BARPPY01
+6 SET DIR(0)="SA^F:FILE;M:MODIFY;Q:QUIT"
+7 SET DIR("A")="FILE PREPAYMENT? SELECT (F)ILE, (M)ODIFY, (Q)UIT: "
+8 KILL DA
+9 DO ^DIR
+10 IF $DATA(DUOUT)!$DATA(DIROUT)
GOTO FMQ
+11 IF $DATA(DTOUT)
QUIT
+12 SET BARFILE=X
+13 ;
+14 ; ---FILE---
+15 IF "Ff"[BARFILE
Begin DoDot:1
+16 ;OK to file (No A/R Bill Selected, or A/R Bill selected and matches item 6 PATIENT)
SET BARTMPF="OK"
+17 ;bar*1.8*19 SDR
IF +$GET(BARPTI1)=0
IF (+$GET(BARBLIEN)=0)
SET BARTMPF="NOB"
+18 ;A/R Bill selected and does not match item 6 PATIENT)
IF $GET(BARPAT)'=""
IF BARPAT'=BARPTI1
SET BARTMPF="NOK"
End DoDot:1
+19 ;start new code bar*1.8*19 SDR
+20 IF "Ff"[BARFILE
IF ($GET(BARTMPF)="NOB")
Begin DoDot:1
+21 WRITE !!,"A PATIENT or a BILL NUMBER is required!"
HANG 1
End DoDot:1
GOTO RECAP
+22 ;end new SDR
+23 IF "Ff"[BARFILE
IF BARTMPF="NOK"
Begin DoDot:1
+24 WRITE !!
+25 SET DIR("A",1)="Patient in Item 5 does not match Patient in Item 6"
+26 SET DIR("A",2)="Do you still want to file this data?"
+27 SET DIR("A",3)=" Enter 'YES' to File data"
+28 SET DIR("A",4)=" Enter 'NO' to Modify data"
+29 SET DIR("A",5)=" "
+30 SET DIR("A")=