BARPRF3 ; IHS/SD/LSL - REFUND COMMAND PROCESSOR MAY 30,1996 ; 05/07/2008
;;1.8;IHS ACCOUNTS RECEIVABLE;**4,21,23***;OCT 26, 2005
;
; IHS/SD/SDR - 10/18/02 - V1.6 Patch 4 - OEA-1002-190010
; Resolve <UNDEF>PARSE+6^XBDIQ1
;
; IHS/SD/LSL - 12/24/02 - V1.7 - XJG-12002-160021
; Allow new adjustment categories 21 and 22
;
; *********************************************************************
;
;** 'Select Command' processor
;APR 2013 CONDITIONAL DISPLAY OF TXD AND MESSSAGES
EN ;EP - refund poster
K DIR,^TEMP($J,"BARPOST"),BARTR
S (BARADJ,BARREF)=0
S BARDFLT=""
W !!
; -------------------------------
;
EN1 ;
K BARCOM,BARTYP,BARCAT,BARATYP,BARAMT,BARLIN,BARSPEC
S BARDSP=1
D HIT1^BARPNP2(BARPASS)
; -------------------------------
;
EN2 ;
W !!
K BARCOM,BARAMT
D:$D(BARHLP)<10 SETHLP^BARPRFU
; -------------------------------
;
ASKLIN ;
I BARCNT=1 S (BARLIN,BARDFLT)=1 G ASKCOM1
D ASKLIN^BARFPST3
I $G(BARLIN)["^" G FINISH
I $G(BARLIN)=0 G FINISH
I BARLIN>0,BARLIN<(BARCNT+1) G ASKCOM1
; -------------------------------
;
LNHLP ;
;
ASKCOM ;EP;
K BARCOM,BARTYP,BARCAT,BARATYP,BARAMT
S BARDSP=1
D HIT1^BARPNP2(BARPASS)
W !
; -------------------------------
;
ASKCOM1 ;
W !,"Select Command (Line # "_BARLIN_") : "
;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
I $$NOTOPEN^BARUFUT(.DUZ,$G(UFMSESID)) Q ;IS SESSION STILL OPEN
R BARCOM:DTIME
S BARCOM=$$UPC^BARUTL(BARCOM)
;start new code IHS/SD/SDR bar*1.8*4 DD item 4.1.7.1
I ("AR"[BARCOM) D I $D(DIROUT)!$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!($G(Y)=0) G ASKCOM
.S BARBLDA=$O(^BARTMP($J,"B",BARLIN,""))
.S BARTPB=$$FIND3PB^BARUTL(DUZ(2),BARBLDA)
.K DIROUT,DIRUT,DTOUT,DUOUT
.K DIR,DIE,DIC,X,Y,DA,DR
.Q:$G(BARTPB)=""
.S BARSTAT=$P($G(^ABMDBILL($P(BARTPB,","),$P(BARTPB,",",2),0)),U,4)
.Q:BARSTAT'="X"
.W !!,"STOP! 3P BILL ",$P($P($G(^BARBL(DUZ(2),BARBLDA,0)),U),"-")," has been cancelled."
.S DIR(0)="Y"
.S DIR("A")="Are you sure you want to post to this invoice"
.S DIR("B")="N"
.D ^DIR K DIR
;end new code IHS/SD/SDR bar*1.8*4 DD item 4.1.7.1
S Q=0
F J=1:1 D Q:Q
.S BARCOM(J)=$P(BARCOM,",",J)
.Q:$L(BARCOM(J))
.K BARCOM(J)
.S J=J-1
.S Q=1 Q
I 'J!($L($G(BARCOM(1)))=0) G ASKCOM
I '$D(BARHLP(BARCOM(1))) G COMHLP
I J=1,BARCOM(J)="M" D G ASKCOM
.N DA,DIC,BARBLDA,BARACC
.S BARBLDA=$O(^BARTMP($J,"B",BARLIN,""))
.S BARACC=$$GET1^DIQ(90050.01,BARBLDA,3,"I")
.D EN^BARPST6(BARPAT,BARBLDA,BARACC)
.Q
I J=1,BARCOM(J)="T" D G ASKCOM
.S Y=$$DSPLY^BARPNP4(BARLIN)
.D EOP^BARUTL(1)
I J=1,BARCOM(J)="H" D HISTORY^BARBAD3 G ASKCOM ;P.OTT
;. S BARBLDA=$O(^BARTMP($J,"B",BARLIN,""))
;. D EN^BARPST5(BARBLDA)
; -------------------------------
;
GOQ ;
;I J=1,BARCOM(J)="Q" G:BARCNT>1 EN1 G FINISH ;BAR*1.8*4 DD 4.1.7.2
I J=1,BARCOM(J)="Q" D G:BARCNT>1 EN1 G FINISH ;BAR*1.8*4 DD 4.1.7.2
.D CKNEG^BARPST3(BARLIN) ;BAR*1.8*4 DD 4.1.7.2
;
;
GOA ;
I J=1,BARCOM(J)="A" S BARTYP="A" G ASKAMT
;
GOD ;
I J=1,BARCOM(J)="D" S DFN=BARPAT D VIEWR^XBLM("START^AGFACE") G ASKCOM
;
GOB ;
I J=1,BARCOM(J)="B" D G ASKCOM
. S BARBLDA=$O(^BARTMP($J,"B",BARLIN,""))
. D DIQ^XBLM(90050.01,BARBLDA)
I J=1,BARCOM(J)="R" S BARTYP="R" G ASKAMT
I J=1,BARCOM(J)="E" G ^BARPNP4
W *7," Sorry.. ["_BARHLP(BARCOM(1))_"] not active!"
G ASKCOM
; *********************************************************************
;
ASKAMT ;
S (BARCAT,BARATYP)=""
S BARASK=$S(BARTYP="R":"Refund ",BARTYP="A":"Adjustment ",1:"")_"Amount: "
W !,BARASK R X:DTIME
S X=$$AMT^BARPRFU(X)
I X="^" G ASKCOM
I X="?" W *7," Must be a valid number!" G ASKAMT
S BARAMT=X
I BARTYP="R" D G RFTYPE
.S BARCAT=19
.S BARAMT=-BARAMT
.Q
;
;** adjustment category/type dialog
S DIC=90052.01
S DIC(0)="AEMNQZ"
S DIC("A")="Adjustment Category: "
S:BARTYP="R" DIC("A")="Refund Category: "
S DIC("S")="I Y=3!(Y=4)!(Y=13)!(Y=14)!(Y=15)!(Y=16)!(Y=20)!(Y=21)!(Y=22)"
S:BARTYP="R" DIC("S")="I Y=19"
K DD,DO
D ^DIC
K DIC
I +Y<0 W *7 K BARAMT W !! G ASKAMT
S BARCAT=+Y
; -------------------------------
;
RFTYPE ;
S BARX=0,BARJ=0
K BARATYP
F S BARX=$O(^BARTBL("D",BARCAT,BARX)) Q:'BARX D Q:BARJ>1
.S BARJ=BARJ+1
.Q:BARJ>1
.S BARATYP=BARX
I BARJ=1,$G(BARATYP) G S1
S DIC=90052.02
S DIC(0)="AEMNQZ"
S DIC("A")="Adjustment Type: "
S DIC("S")="I $P(^(0),U,2)=BARCAT"
K DD,DO
D ^DIC
K DIC
I +Y<0 K BARAMT W *7,!! G ASKAMT
S BARATYP=+Y
;--------------------------------
;
S1 ;
D SETTMP^BARPRF3A(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP)
G ASKCOM
; *********************************************************************
;
COMHLP ;
D COMHLP^BARPRFU
G ASKCOM1
; *********************************************************************
;
FINISH ;
I '$G(BARREF)&('$G(BARADJ)) D CANCEL Q
FIN S BARQ=$$POST() ;BAR*1.8*4 DD 4.1.7.2
I BARQ="M" G EN1
I BARQ="C" D CANCEL Q
;I BARQ="P" D POSTTX^BARPRFU,EN^BARROLL Q ;BAR*1.8*4 DD 4.1.7.2
I BARQ="P" D I $G(BARSTOP)=1 G FIN ;BAR*1.8*4 DD 4.1.7.2
.K BARCOL D POSTTX^BARPSTU ;BAR*1.8*4 DD 4.1.7.2
D EN^BARROLL
K ^BARTMP($J) ;BAR*1.8*4 DD 4.1.7.2
Q
; -------------------------------
;
POST() ;
P1 ;
D HIT1^BARPNP2(BARPASS)
D EOP^BARUTL(2)
;
PDIR ;
K DIR
S DIR(0)="SAO^P:POST TO A/R;M:MORE;C:CANCEL"
S DIR("A")="Select Action (P/M/C): "
D ^DIR
K DIR
I $D(DUOUT)!(Y="") W *7 G PDIR
Q Y
; *********************************************************************
;
CANCEL ;
K ^BARTMP($J)
K BARREF,BARADJ,BARTR
Q
;***************************
BARPRF3 ; IHS/SD/LSL - REFUND COMMAND PROCESSOR MAY 30,1996 ; 05/07/2008
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**4,21,23***;OCT 26, 2005
+2 ;
+3 ; IHS/SD/SDR - 10/18/02 - V1.6 Patch 4 - OEA-1002-190010
+4 ; Resolve <UNDEF>PARSE+6^XBDIQ1
+5 ;
+6 ; IHS/SD/LSL - 12/24/02 - V1.7 - XJG-12002-160021
+7 ; Allow new adjustment categories 21 and 22
+8 ;
+9 ; *********************************************************************
+10 ;
+11 ;** 'Select Command' processor
+12 ;APR 2013 CONDITIONAL DISPLAY OF TXD AND MESSSAGES
EN ;EP - refund poster
+1 KILL DIR,^TEMP($JOB,"BARPOST"),BARTR
+2 SET (BARADJ,BARREF)=0
+3 SET BARDFLT=""
+4 WRITE !!
+5 ; -------------------------------
+6 ;
EN1 ;
+1 KILL BARCOM,BARTYP,BARCAT,BARATYP,BARAMT,BARLIN,BARSPEC
+2 SET BARDSP=1
+3 DO HIT1^BARPNP2(BARPASS)
+4 ; -------------------------------
+5 ;
EN2 ;
+1 WRITE !!
+2 KILL BARCOM,BARAMT
+3 IF $DATA(BARHLP)<10
DO SETHLP^BARPRFU
+4 ; -------------------------------
+5 ;
ASKLIN ;
+1 IF BARCNT=1
SET (BARLIN,BARDFLT)=1
GOTO ASKCOM1
+2 DO ASKLIN^BARFPST3
+3 IF $GET(BARLIN)["^"
GOTO FINISH
+4 IF $GET(BARLIN)=0
GOTO FINISH
+5 IF BARLIN>0
IF BARLIN<(BARCNT+1)
GOTO ASKCOM1
+6 ; -------------------------------
+7 ;
LNHLP ;
+1 ;
ASKCOM ;EP;
+1 KILL BARCOM,BARTYP,BARCAT,BARATYP,BARAMT
+2 SET BARDSP=1
+3 DO HIT1^BARPNP2(BARPASS)
+4 WRITE !
+5 ; -------------------------------
+6 ;
ASKCOM1 ;
+1 WRITE !,"Select Command (Line # "_BARLIN_") : "
+2 ;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
+3 ;IS SESSION STILL OPEN
IF $$NOTOPEN^BARUFUT(.DUZ,$GET(UFMSESID))
QUIT
+4 READ BARCOM:DTIME
+5 SET BARCOM=$$UPC^BARUTL(BARCOM)
+6 ;start new code IHS/SD/SDR bar*1.8*4 DD item 4.1.7.1
+7 IF ("AR"[BARCOM)
Begin DoDot:1
+8 SET BARBLDA=$ORDER(^BARTMP($JOB,"B",BARLIN,""))
+9 SET BARTPB=$$FIND3PB^BARUTL(DUZ(2),BARBLDA)
+10 KILL DIROUT,DIRUT,DTOUT,DUOUT
+11 KILL DIR,DIE,DIC,X,Y,DA,DR
+12 IF $GET(BARTPB)=""
QUIT
+13 SET BARSTAT=$PIECE($GET(^ABMDBILL($PIECE(BARTPB,","),$PIECE(BARTPB,",",2),0)),U,4)
+14 IF BARSTAT'="X"
QUIT
+15 WRITE !!,"STOP! 3P BILL ",$PIECE($PIECE($GET(^BARBL(DUZ(2),BARBLDA,0)),U),"-")," has been cancelled."
+16 SET DIR(0)="Y"
+17 SET DIR("A")="Are you sure you want to post to this invoice"
+18 SET DIR("B")="N"
+19 DO ^DIR
KILL DIR
End DoDot:1
IF $DATA(DIROUT)!$DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!($GET(Y)=0)
GOTO ASKCOM
+20 ;end new code IHS/SD/SDR bar*1.8*4 DD item 4.1.7.1
+21 SET Q=0
+22 FOR J=1:1
Begin DoDot:1
+23 SET BARCOM(J)=$PIECE(BARCOM,",",J)
+24 IF $LENGTH(BARCOM(J))
QUIT
+25 KILL BARCOM(J)
+26 SET J=J-1
+27 SET Q=1
QUIT
End DoDot:1
IF Q
QUIT
+28 IF 'J!($LENGTH($GET(BARCOM(1)))=0)
GOTO ASKCOM
+29 IF '$DATA(BARHLP(BARCOM(1)))
GOTO COMHLP
+30 IF J=1
IF BARCOM(J)="M"
Begin DoDot:1
+31 NEW DA,DIC,BARBLDA,BARACC
+32 SET BARBLDA=$ORDER(^BARTMP($JOB,"B",BARLIN,""))
+33 SET BARACC=$$GET1^DIQ(90050.01,BARBLDA,3,"I")
+34 DO EN^BARPST6(BARPAT,BARBLDA,BARACC)
+35 QUIT
End DoDot:1
GOTO ASKCOM
+36 IF J=1
IF BARCOM(J)="T"
Begin DoDot:1
+37 SET Y=$$DSPLY^BARPNP4(BARLIN)
+38 DO EOP^BARUTL(1)
End DoDot:1
GOTO ASKCOM
+39 ;P.OTT
IF J=1
IF BARCOM(J)="H"
DO HISTORY^BARBAD3
GOTO ASKCOM
+40 ;. S BARBLDA=$O(^BARTMP($J,"B",BARLIN,""))
+41 ;. D EN^BARPST5(BARBLDA)
+42 ; -------------------------------
+43 ;
GOQ ;
+1 ;I J=1,BARCOM(J)="Q" G:BARCNT>1 EN1 G FINISH ;BAR*1.8*4 DD 4.1.7.2
+2 ;BAR*1.8*4 DD 4.1.7.2
IF J=1
IF BARCOM(J)="Q"
Begin DoDot:1
+3 ;BAR*1.8*4 DD 4.1.7.2
DO CKNEG^BARPST3(BARLIN)
End DoDot:1
IF BARCNT>1
GOTO EN1
GOTO FINISH
+4 ;
+5 ;
GOA ;
+1 IF J=1
IF BARCOM(J)="A"
SET BARTYP="A"
GOTO ASKAMT
+2 ;
GOD ;
+1 IF J=1
IF BARCOM(J)="D"
SET DFN=BARPAT
DO VIEWR^XBLM("START^AGFACE")
GOTO ASKCOM
+2 ;
GOB ;
+1 IF J=1
IF BARCOM(J)="B"
Begin DoDot:1
+2 SET BARBLDA=$ORDER(^BARTMP($JOB,"B",BARLIN,""))
+3 DO DIQ^XBLM(90050.01,BARBLDA)
End DoDot:1
GOTO ASKCOM
+4 IF J=1
IF BARCOM(J)="R"
SET BARTYP="R"
GOTO ASKAMT
+5 IF J=1
IF BARCOM(J)="E"
GOTO ^BARPNP4
+6 WRITE *7," Sorry.. ["_BARHLP(BARCOM(1))_"] not active!"
+7 GOTO ASKCOM
+8 ; *********************************************************************
+9 ;
ASKAMT ;
+1 SET (BARCAT,BARATYP)=""
+2 SET BARASK=$SELECT(BARTYP="R":"Refund ",BARTYP="A":"Adjustment ",1:"")_"Amount: "
+3 WRITE !,BARASK
READ X:DTIME
+4 SET X=$$AMT^BARPRFU(X)
+5 IF X="^"
GOTO ASKCOM
+6 IF X="?"
WRITE *7," Must be a valid number!"
GOTO ASKAMT
+7 SET BARAMT=X
+8 IF BARTYP="R"
Begin DoDot:1
+9 SET BARCAT=19
+10 SET BARAMT=-BARAMT
+11 QUIT
End DoDot:1
GOTO RFTYPE
+12 ;
+13 ;** adjustment category/type dialog
+14 SET DIC=90052.01
+15 SET DIC(0)="AEMNQZ"
+16 SET DIC("A")="Adjustment Category: "
+17 IF BARTYP="R"
SET DIC("A")="Refund Category: "
+18 SET DIC("S")="I Y=3!(Y=4)!(Y=13)!(Y=14)!(Y=15)!(Y=16)!(Y=20)!(Y=21)!(Y=22)"
+19 IF BARTYP="R"
SET DIC("S")="I Y=19"
+20 KILL DD,DO
+21 DO ^DIC
+22 KILL DIC
+23 IF +Y<0
WRITE *7
KILL BARAMT
WRITE !!
GOTO ASKAMT
+24 SET BARCAT=+Y
+25 ; -------------------------------
+26 ;
RFTYPE ;
+1 SET BARX=0
SET BARJ=0
+2 KILL BARATYP
+3 FOR
SET BARX=$ORDER(^BARTBL("D",BARCAT,BARX))
IF 'BARX
QUIT
Begin DoDot:1
+4 SET BARJ=BARJ+1
+5 IF BARJ>1
QUIT
+6 SET BARATYP=BARX
End DoDot:1
IF BARJ>1
QUIT
+7 IF BARJ=1
IF $GET(BARATYP)
GOTO S1
+8 SET DIC=90052.02
+9 SET DIC(0)="AEMNQZ"
+10 SET DIC("A")="Adjustment Type: "
+11 SET DIC("S")="I $P(^(0),U,2)=BARCAT"
+12 KILL DD,DO
+13 DO ^DIC
+14 KILL DIC
+15 IF +Y<0
KILL BARAMT
WRITE *7,!!
GOTO ASKAMT
+16 SET BARATYP=+Y
+17 ;--------------------------------
+18 ;
S1 ;
+1 DO SETTMP^BARPRF3A(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP)
+2 GOTO ASKCOM
+3 ; *********************************************************************
+4 ;
COMHLP ;
+1 DO COMHLP^BARPRFU
+2 GOTO ASKCOM1
+3 ; *********************************************************************
+4 ;
FINISH ;
+1 IF '$GET(BARREF)&('$GET(BARADJ))
DO CANCEL
QUIT
FIN ;BAR*1.8*4 DD 4.1.7.2
SET BARQ=$$POST()
+1 IF BARQ="M"
GOTO EN1
+2 IF BARQ="C"
DO CANCEL
QUIT
+3 ;I BARQ="P" D POSTTX^BARPRFU,EN^BARROLL Q ;BAR*1.8*4 DD 4.1.7.2
+4 ;BAR*1.8*4 DD 4.1.7.2
IF BARQ="P"
Begin DoDot:1
+5 ;BAR*1.8*4 DD 4.1.7.2
KILL BARCOL
DO POSTTX^BARPSTU
End DoDot:1
IF $GET(BARSTOP)=1
GOTO FIN
+6 DO EN^BARROLL
+7 ;BAR*1.8*4 DD 4.1.7.2
KILL ^BARTMP($JOB)
+8 QUIT
+9 ; -------------------------------
+10 ;
POST() ;
P1 ;
+1 DO HIT1^BARPNP2(BARPASS)
+2 DO EOP^BARUTL(2)
+3 ;
PDIR ;
+1 KILL DIR
+2 SET DIR(0)="SAO^P:POST TO A/R;M:MORE;C:CANCEL"
+3 SET DIR("A")="Select Action (P/M/C): "
+4 DO ^DIR
+5 KILL DIR
+6 IF $DATA(DUOUT)!(Y="")
WRITE *7
GOTO PDIR
+7 QUIT Y
+8 ; *********************************************************************
+9 ;
CANCEL ;
+1 KILL ^BARTMP($JOB)
+2 KILL BARREF,BARADJ,BARTR
+3 QUIT
+4 ;***************************
