BARPNP3 ; IHS/SD/LSL - POSTING SELECT COMMAND PROCESSOR ; 05/07/2008
;;1.8;IHS ACCOUNTS RECEIVABLE;**4,21,24**;OCT 26, 2005;Build 69
;** 'Select Command' processor
;
; IHS/SD/LSL - 09/23/02 - V1.6 Patch 3 - HIPAA
; Allow user to select new Adjustment Categories PENDING
; or GENERAL INFORMATION
;
; IHS/SD/SDR - 10/18/02 - V1.7 - OEA-1002-190010
; Resolve <UNDEF> PARSE+6^XBDIQ1
;
; IHS/SD/LS - 10/17/03 - V1.7 Patch 4
; Allow rollover even if previously rolled.
;
; IHS/SD/POT - NOHEAT 03/31/14 - BAR*1.8*24 LIMIT INPUT LENGTH
; ********************************************************************
;
EN ;EP - posting command handler
K DIR,BARTR
K ^TEMP($J,"BARPOST")
S (BARADJ,BARPMT)=0
S BARDFLT=""
W !!
; -------------------------------
;
EN1 ;
K BARCOM,BARTYP,BARCAT,BARATYP,BARAMT,BARLIN
S BARDSP=1
D HIT1^BARPNP2(BARPASS)
; -------------------------------
;
EN2 ;
W !!
K BARCOM,BARAMT
D:$D(BARHLP)<10 SETHLP^BARPNPU
; -------------------------------
;
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 - select command
K BARCOM,BARTYP,BARCAT,BARATYP,BARAMT
S BARDSP=1
D HIT1^BARPNP2(BARPASS)
W !
; -------------------------------
;
ASKCOM1 ;
I $$NOTOPEN^BARUFUT(.DUZ,$G(UFMSESID)) Q ;IS SESSION STILL OPEN
W !,"Select Command (Line # "_BARLIN_") : "
;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
R BARCOM:DTIME
S BARCOM=$E(BARCOM,1,10) ;BAR*1.8*24
S BARCOM=$$UPC^BARUTL(BARCOM)
;start new code IHS/SD/SDR bar*1.8*4 DD item 4.1.7.1
I ("P1A2"[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 BARCOM(1)=2 S BARCOM(1)="A" W *7,*7,*7
I BARCOM(1)=3 S BARCOM(1)="Q" W *7,*7,*7
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
I J=1,BARCOM(J)="R" D ROLL G ASKCOM
;
;enable posting rollback
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
I J=1,BARCOM(J)="2" S BARTYP="A" G ASKAMT
I J=1,BARCOM(J)="E" G ^BARPNP4
;
GOD ;
I J=1,BARCOM(J)="D" D G ASKCOM
. S DFN=BARPAT
. D VIEWR^XBLM("START^AGFACE")
;
GOB ;
I J=1,BARCOM(J)="B" D G ASKCOM
. S BARBLDA=$O(^BARTMP($J,"B",BARLIN,""))
. D DIQ^XBLM(90050.01,BARBLDA)
W *7,!," Sorry.. ["_BARHLP(BARCOM(1))_"] not active!"
D EOP^BARUTL(1)
G ASKCOM
; *********************************************************************
;
ASKAMT ;
S (BARCAT,BARATYP)=""
S BARASK=$S(BARTYP="P":"Payment ",BARTYP="A":"Adjustment ",1:"")_"Amount: "
W !,BARASK R X:DTIME
S X=$$AMT^BARPNPU(X)
I X="^" G ASKCOM
I X="?" W *7," Must be a valid number!" G ASKAMT
S BARAMT=X
I BARTYP="P" D G S1
. S BARCAT=$O(^BAR(90052.01,"B","PAYMENT TYPE",""))
. Q
;
;** adjustment category/type dialog
S DIC=90052.01
S DIC(0)="AEMNQZ"
S DIC("A")="Adjustment Category: "
S DIC("S")="I "",3,4,13,14,15,16,20,21,22,""[("",""_Y_"","")"
D ^DIC
K DIC
I +Y<0 W *7 K BARAMT W !! G ASKAMT
S BARCAT=+Y
S:BARCAT=16 BARAMT=-BARAMT ;grouper
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"
D ^DIC
K DIC
I +Y<0 K BARAMT W *7,!! G ASKAMT
S BARATYP=+Y
; -------------------------------
;
S1 ;
;D SETTMP^BARPST3A(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP) ;BAR*1.8*4 DD 4.1.7.2
D SETTMP^BARPST3A(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP,0) ;BAR*1.8*4 DD 4.1.7.2
G ASKCOM
; *********************************************************************
;
COMHLP ;
D COMHLP^BARPNPU
G ASKCOM1
; *********************************************************************
;
FINISH ;
I '$G(BARPMT)&('$G(BARADJ))&'$D(BARROLL)&'$D(BARTR) D CANCEL Q
; enable posting rollback
;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
I $$NOTOPEN^BARUFUT(.DUZ,$G(UFMSESID)) D CANCEL Q ;IS SESSION STILL OPEN
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^BARPNPU,EN^BARROLL Q ;BAR*1.8*4 DD 4.1.7.2
I BARQ="P" K BARCOL D POSTTX^BARPSTU ;BAR*1.8*4 DD 4.1.7.2
I $G(BARSTOP)=1 G FIN ;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
; *********************************************************************
;
ROLL ;EP - tag a bill for rollback to 3P
; enable posting rollback
N BARBLDA
S BARBLDA=$O(^BARTMP($J,"B",BARLIN,""))
S BARROLL(BARBLDA)=""
K DIC,DIE
S DIE="^BARBL(DUZ(2),"
S DA=BARBLDA
S DR="214///@"
D ^DIE
K DIC,DIE,X,Y,DR
K DIR
S DIR("A")="TAGGED for Rolling. Enter RETURN to Continue."
D EOP^BARUTL(0)
ROLLE ;
Q
; *********************************************************************
;
CANCEL ;
K ^BARTMP($J)
K BARPMT,BARADJ,BARTR
Q
BARPNP3 ; IHS/SD/LSL - POSTING SELECT COMMAND PROCESSOR ; 05/07/2008
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**4,21,24**;OCT 26, 2005;Build 69
+2 ;** 'Select Command' processor
+3 ;
+4 ; IHS/SD/LSL - 09/23/02 - V1.6 Patch 3 - HIPAA
+5 ; Allow user to select new Adjustment Categories PENDING
+6 ; or GENERAL INFORMATION
+7 ;
+8 ; IHS/SD/SDR - 10/18/02 - V1.7 - OEA-1002-190010
+9 ; Resolve <UNDEF> PARSE+6^XBDIQ1
+10 ;
+11 ; IHS/SD/LS - 10/17/03 - V1.7 Patch 4
+12 ; Allow rollover even if previously rolled.
+13 ;
+14 ; IHS/SD/POT - NOHEAT 03/31/14 - BAR*1.8*24 LIMIT INPUT LENGTH
+15 ; ********************************************************************
+16 ;
EN ;EP - posting command handler
+1 KILL DIR,BARTR
+2 KILL ^TEMP($JOB,"BARPOST")
+3 SET (BARADJ,BARPMT)=0
+4 SET BARDFLT=""
+5 WRITE !!
+6 ; -------------------------------
+7 ;
EN1 ;
+1 KILL BARCOM,BARTYP,BARCAT,BARATYP,BARAMT,BARLIN
+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^BARPNPU
+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 - select command
+1 KILL BARCOM,BARTYP,BARCAT,BARATYP,BARAMT
+2 SET BARDSP=1
+3 DO HIT1^BARPNP2(BARPASS)
+4 WRITE !
+5 ; -------------------------------
+6 ;
ASKCOM1 ;
+1 ;IS SESSION STILL OPEN
IF $$NOTOPEN^BARUFUT(.DUZ,$GET(UFMSESID))
QUIT
+2 WRITE !,"Select Command (Line # "_BARLIN_") : "
+3 ;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
+4 READ BARCOM:DTIME
+5 ;BAR*1.8*24
SET BARCOM=$EXTRACT(BARCOM,1,10)
+6 SET BARCOM=$$UPC^BARUTL(BARCOM)
+7 ;start new code IHS/SD/SDR bar*1.8*4 DD item 4.1.7.1
+8 IF ("P1A2"[BARCOM)
Begin DoDot:1
+9 SET BARBLDA=$ORDER(^BARTMP($JOB,"B",BARLIN,""))
+10 SET BARTPB=$$FIND3PB^BARUTL(DUZ(2),BARBLDA)
+11 KILL DIROUT,DIRUT,DTOUT,DUOUT
+12 KILL DIR,DIE,DIC,X,Y,DA,DR
+13 IF $GET(BARTPB)=""
QUIT
+14 SET BARSTAT=$PIECE($GET(^ABMDBILL($PIECE(BARTPB,","),$PIECE(BARTPB,",",2),0)),U,4)
+15 IF BARSTAT'="X"
QUIT
+16 WRITE !!,"STOP! 3P BILL ",$PIECE($PIECE($GET(^BARBL(DUZ(2),BARBLDA,0)),U),"-")," has been cancelled."
+17 SET DIR(0)="Y"
+18 SET DIR("A")="Are you sure you want to post to this invoice"
+19 SET DIR("B")="N"
+20 DO ^DIR
KILL DIR
End DoDot:1
IF $DATA(DIROUT)!$DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!($GET(Y)=0)
GOTO ASKCOM
+21 ;end new code IHS/SD/SDR bar*1.8*4 DD item 4.1.7.1
+22 SET Q=0
+23 FOR J=1:1
Begin DoDot:1
+24 SET BARCOM(J)=$PIECE(BARCOM,",",J)
+25 IF $LENGTH(BARCOM(J))
QUIT
+26 KILL BARCOM(J)
+27 SET J=J-1
+28 SET Q=1
QUIT
End DoDot:1
IF Q
QUIT
+29 IF 'J!($LENGTH($GET(BARCOM(1)))=0)
GOTO ASKCOM
+30 IF BARCOM(1)=2
SET BARCOM(1)="A"
WRITE *7,*7,*7
+31 IF BARCOM(1)=3
SET BARCOM(1)="Q"
WRITE *7,*7,*7
+32 IF '$DATA(BARHLP(BARCOM(1)))
GOTO COMHLP
+33 IF J=1
IF BARCOM(J)="M"
Begin DoDot:1
+34 NEW DA,DIC,BARBLDA,BARACC
+35 SET BARBLDA=$ORDER(^BARTMP($JOB,"B",BARLIN,""))
+36 SET BARACC=$$GET1^DIQ(90050.01,BARBLDA,3,"I")
+37 DO EN^BARPST6(BARPAT,BARBLDA,BARACC)
+38 QUIT
End DoDot:1
GOTO ASKCOM
+39 IF J=1
IF BARCOM(J)="T"
Begin DoDot:1
+40 SET Y=$$DSPLY^BARPNP4(BARLIN)
+41 DO EOP^BARUTL(1)
End DoDot:1
GOTO ASKCOM
+42 IF J=1
IF BARCOM(J)="H"
DO HISTORY^BARBAD3
GOTO ASKCOM
+43 IF J=1
IF BARCOM(J)="R"
DO ROLL
GOTO ASKCOM
+44 ;
+45 ;enable posting rollback
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 ;
GOA ;
+1 IF J=1
IF BARCOM(J)="A"
SET BARTYP="A"
GOTO ASKAMT
+2 IF J=1
IF BARCOM(J)="2"
SET BARTYP="A"
GOTO ASKAMT
+3 IF J=1
IF BARCOM(J)="E"
GOTO ^BARPNP4
+4 ;
GOD ;
+1 IF J=1
IF BARCOM(J)="D"
Begin DoDot:1
+2 SET DFN=BARPAT
+3 DO VIEWR^XBLM("START^AGFACE")
End DoDot:1
GOTO ASKCOM
+4 ;
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 WRITE *7,!," Sorry.. ["_BARHLP(BARCOM(1))_"] not active!"
+5 DO EOP^BARUTL(1)
+6 GOTO ASKCOM
+7 ; *********************************************************************
+8 ;
ASKAMT ;
+1 SET (BARCAT,BARATYP)=""
+2 SET BARASK=$SELECT(BARTYP="P":"Payment ",BARTYP="A":"Adjustment ",1:"")_"Amount: "
+3 WRITE !,BARASK
READ X:DTIME
+4 SET X=$$AMT^BARPNPU(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="P"
Begin DoDot:1
+9 SET BARCAT=$ORDER(^BAR(90052.01,"B","PAYMENT TYPE",""))
+10 QUIT
End DoDot:1
GOTO S1
+11 ;
+12 ;** adjustment category/type dialog
+13 SET DIC=90052.01
+14 SET DIC(0)="AEMNQZ"
+15 SET DIC("A")="Adjustment Category: "
+16 SET DIC("S")="I "",3,4,13,14,15,16,20,21,22,""[("",""_Y_"","")"
+17 DO ^DIC
+18 KILL DIC
+19 IF +Y<0
WRITE *7
KILL BARAMT
WRITE !!
GOTO ASKAMT
+20 SET BARCAT=+Y
+21 ;grouper
IF BARCAT=16
SET BARAMT=-BARAMT
+22 SET BARX=0
SET BARJ=0
+23 KILL BARATYP
+24 FOR
SET BARX=$ORDER(^BARTBL("D",BARCAT,BARX))
IF 'BARX
QUIT
Begin DoDot:1
+25 SET BARJ=BARJ+1
+26 IF BARJ>1
QUIT
+27 SET BARATYP=BARX
End DoDot:1
IF BARJ>1
QUIT
+28 IF BARJ=1
IF $GET(BARATYP)
GOTO S1
+29 SET DIC=90052.02
+30 SET DIC(0)="AEMNQZ"
+31 SET DIC("A")="Adjustment Type: "
+32 SET DIC("S")="I $P(^(0),U,2)=BARCAT"
+33 DO ^DIC
+34 KILL DIC
+35 IF +Y<0
KILL BARAMT
WRITE *7,!!
GOTO ASKAMT
+36 SET BARATYP=+Y
+37 ; -------------------------------
+38 ;
S1 ;
+1 ;D SETTMP^BARPST3A(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP) ;BAR*1.8*4 DD 4.1.7.2
+2 ;BAR*1.8*4 DD 4.1.7.2
DO SETTMP^BARPST3A(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP,0)
+3 GOTO ASKCOM
+4 ; *********************************************************************
+5 ;
COMHLP ;
+1 DO COMHLP^BARPNPU
+2 GOTO ASKCOM1
+3 ; *********************************************************************
+4 ;
FINISH ;
+1 IF '$GET(BARPMT)&('$GET(BARADJ))&'$DATA(BARROLL)&'$DATA(BARTR)
DO CANCEL
QUIT
+2 ; enable posting rollback
+3 ;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
+4 ;IS SESSION STILL OPEN
IF $$NOTOPEN^BARUFUT(.DUZ,$GET(UFMSESID))
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^BARPNPU,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"
KILL BARCOL
DO POSTTX^BARPSTU
+5 ;BAR*1.8*4 DD 4.1.7.2
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 KILL DIR
+1 SET DIR(0)="SAO^P:POST TO A/R;M:MORE;C:CANCEL"
+2 SET DIR("A")="Select Action (P/M/C): "
+3 DO ^DIR
+4 KILL DIR
+5 IF $DATA(DUOUT)!(Y="")
WRITE *7
GOTO PDIR
+6 QUIT Y
+7 ; *********************************************************************
+8 ;
ROLL ;EP - tag a bill for rollback to 3P
+1 ; enable posting rollback
+2 NEW BARBLDA
+3 SET BARBLDA=$ORDER(^BARTMP($JOB,"B",BARLIN,""))
+4 SET BARROLL(BARBLDA)=""
+5 KILL DIC,DIE
+6 SET DIE="^BARBL(DUZ(2),"
+7 SET DA=BARBLDA
+8 SET DR="214///@"
+9 DO ^DIE
+10 KILL DIC,DIE,X,Y,DR
+11 KILL DIR
+12 SET DIR("A")="TAGGED for Rolling. Enter RETURN to Continue."
+13 DO EOP^BARUTL(0)
ROLLE ;
+1 QUIT
+2 ; *********************************************************************
+3 ;
CANCEL ;
+1 KILL ^BARTMP($JOB)
+2 KILL BARPMT,BARADJ,BARTR
+3 QUIT
