BARPUC3 ; IHS/SD/LSL - UNALLOCATED COMMAND PROCESSING ; 07/16/2008
;;1.8;IHS ACCOUNTS RECEIVABLE;**4,21,23***;OCT 26, 2005
;
; IHS/SD/SDR - 10/18/02 - V1.7 - OEA-1002-190010
; Resolve <UNDEF>PARSE+6^XBDIQ1
;
; IHS/SD/LSL - 12/24/02 - V1.7 - XJG-1202-160021
; Allow new adjustment categories 21 and 22
;
; *********************************************************************
; ;APR 2013 CONDITIONAL DISPLAY OF TXD AND MESSSAGES
;** 'Select Command' processor
;
EN ;EP - command processor for unallocated
K DIR,^TEMP($J,"BARPOST"),BARTR
S (BARADJ,BARPMT)=0
S BARDFLT=""
W !!
; -------------------------------
;
EN1 ;
K BARCOM,BARTYP,BARCAT,BARATYP,BARAMT,BARLIN
S BARDSP=1
D HIT1^BARPUC2(BARPASS)
; -------------------------------
;
EN2 ;
W !!
K BARCOM,BARAMT
D:$D(BARHLP)<10 SETHLP^BARPUCU
; -------------------------------
;
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 - ask command
K BARCOM,BARTYP,BARCAT,BARATYP,BARAMT
S BARDSP=1
D HIT1^BARPUC2(BARPASS)
W !
; -------------------------------
;
ASKCOM1 ;
;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
I $$NOTOPEN^BARUFUT(.DUZ,$G(UFMSESID)) Q ;IS SESSION STILL OPEN
W !,"Select Command (Line # "_BARLIN_") : "
R BARCOM:DTIME
;K DIR
;S DIR(0)="FAO"
;S DIR("A")="Select Command (Line # "_BARLIN_") "
;S DIR("T")=DTIME
;D ^DIR
;K DIR
;S BARCOM=$$UPC^BARUTL(X)
S BARCOM=$$UPC^BARUTL(BARCOM)
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
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^BARPUC4(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
; -------------------------------
;
GOP ;
I J=1,BARCOM(J)="P" S BARTYP="P" G ASKAMT
I J=1,BARCOM(J)="1" S BARTYP="P" G ASKAMT
; -------------------------------
;
GOA ;
I J=1,BARCOM(J)="A" S BARTYP="A" G ASKAMT
I J=1,BARCOM(J)="2" S BARTYP="A" G ASKAMT
; -------------------------------
;
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)
I J=1,BARCOM(J)="E" G ^BARPUC4
W *7," Sorry.. ["_BARHLP(BARCOM(1))_"] not active!"
G ASKCOM
; *********************************************************************
;
ASKAMT ;
S (BARCAT,BARATYP)=""
S BARASK=$S(BARTYP="P":"Payment ",BARTYP="A":"Adjustment ",1:"")_"Amount: "
S BARBAL=(BARTX(2)-$G(BARPMT))
W !,BARASK
I BARTYP="P" W $J(BARBAL,0,2)_"// "
R X:DTIME
I BARTYP="P",X="" S X=+BARBAL
I BARTYP="P" S X=$$AMT^BARPUCU(X,0,BARBAL)
I BARTYP="A" S X=$$AMT^BARPUCU(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",""))
;
;** adjustment category/type dialog
S DIC=90052.01
S DIC(0)="AEMNQZ"
S DIC("A")="Adjustment Category: "
S DIC("S")="I Y=3!(Y=4)!(Y=13)!(Y=14)!(Y=15)!(Y=16)!(Y=20)!(Y=21)!(Y=22)"
K DD,DO
D ^DIC
K DIC
I +Y<0 W *7 K BARAMT W !! G ASKAMT
S BARCAT=+Y
S:BARCAT=16 BARAMT=-BARAMT
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^BARPUC3A(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP)
G ASKCOM
; *********************************************************************
;
COMHLP ;
D COMHLP^BARPUCU
G ASKCOM1
; *********************************************************************
;
FINISH ;
I '$G(BARPMT)&('$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 Q ;REWRITTEN ;BAR*1.8*4 DD 4.1.7.2
;. D POSTTX^BARPUCU
;. D EN^BARROLL
I BARQ="P" D POSTTX^BARPUCU ;BAR*1.8*4 DD 4.1.7.2
;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
I $$NOTOPEN^BARUFUT(.DUZ,$G(UFMSESID)) Q ;IS SESSION STILL OPEN
I $G(BARSTOP)=1 G FIN
D EN^BARROLL
K ^BARTMP($J)
Q
; -------------------------------
;
POST() ;
P1 ;
D HIT1^BARPUC2(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 BARPMT,BARADJ,BARTR
Q
BARPUC3 ; IHS/SD/LSL - UNALLOCATED COMMAND PROCESSING ; 07/16/2008
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**4,21,23***;OCT 26, 2005
+2 ;
+3 ; IHS/SD/SDR - 10/18/02 - V1.7 - OEA-1002-190010
+4 ; Resolve <UNDEF>PARSE+6^XBDIQ1
+5 ;
+6 ; IHS/SD/LSL - 12/24/02 - V1.7 - XJG-1202-160021
+7 ; Allow new adjustment categories 21 and 22
+8 ;
+9 ; *********************************************************************
+10 ; ;APR 2013 CONDITIONAL DISPLAY OF TXD AND MESSSAGES
+11 ;** 'Select Command' processor
+12 ;
EN ;EP - command processor for unallocated
+1 KILL DIR,^TEMP($JOB,"BARPOST"),BARTR
+2 SET (BARADJ,BARPMT)=0
+3 SET BARDFLT=""
+4 WRITE !!
+5 ; -------------------------------
+6 ;
EN1 ;
+1 KILL BARCOM,BARTYP,BARCAT,BARATYP,BARAMT,BARLIN
+2 SET BARDSP=1
+3 DO HIT1^BARPUC2(BARPASS)
+4 ; -------------------------------
+5 ;
EN2 ;
+1 WRITE !!
+2 KILL BARCOM,BARAMT
+3 IF $DATA(BARHLP)<10
DO SETHLP^BARPUCU
+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 - ask command
+1 KILL BARCOM,BARTYP,BARCAT,BARATYP,BARAMT
+2 SET BARDSP=1
+3 DO HIT1^BARPUC2(BARPASS)
+4 WRITE !
+5 ; -------------------------------
+6 ;
ASKCOM1 ;
+1 ;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
+2 ;IS SESSION STILL OPEN
IF $$NOTOPEN^BARUFUT(.DUZ,$GET(UFMSESID))
QUIT
+3 WRITE !,"Select Command (Line # "_BARLIN_") : "
+4 READ BARCOM:DTIME
+5 ;K DIR
+6 ;S DIR(0)="FAO"
+7 ;S DIR("A")="Select Command (Line # "_BARLIN_") "
+8 ;S DIR("T")=DTIME
+9 ;D ^DIR
+10 ;K DIR
+11 ;S BARCOM=$$UPC^BARUTL(X)
+12 SET BARCOM=$$UPC^BARUTL(BARCOM)
+13 SET Q=0
+14 FOR J=1:1
Begin DoDot:1
+15 SET BARCOM(J)=$PIECE(BARCOM,",",J)
+16 IF $LENGTH(BARCOM(J))
QUIT
+17 KILL BARCOM(J)
+18 SET J=J-1
+19 SET Q=1
End DoDot:1
IF Q
QUIT
+20 IF 'J!($LENGTH($GET(BARCOM(1)))=0)
GOTO ASKCOM
+21 IF '$DATA(BARHLP(BARCOM(1)))
GOTO COMHLP
+22 IF J=1
IF BARCOM(J)="M"
Begin DoDot:1
+23 NEW DA,DIC,BARBLDA,BARACC
+24 SET BARBLDA=$ORDER(^BARTMP($JOB,"B",BARLIN,""))
+25 SET BARACC=$$GET1^DIQ(90050.01,BARBLDA,3,"I")
+26 DO EN^BARPST6(BARPAT,BARBLDA,BARACC)
+27 QUIT
End DoDot:1
GOTO ASKCOM
+28 IF J=1
IF BARCOM(J)="T"
Begin DoDot:1
+29 SET Y=$$DSPLY^BARPUC4(BARLIN)
+30 DO EOP^BARUTL(1)
End DoDot:1
GOTO ASKCOM
+31 ;P.OTT
IF J=1
IF BARCOM(J)="H"
DO HISTORY^BARBAD3
GOTO ASKCOM
+32 ;S BARBLDA=$O(^BARTMP($J,"B",BARLIN,""))
+33 ;D EN^BARPST5(BARBLDA)
+34 ; -------------------------------
+35 ;
GOQ ;
+1 IF J=1
IF BARCOM(J)="Q"
IF BARCNT>1
GOTO EN1
GOTO FINISH
+2 ; -------------------------------
+3 ;
GOP ;
+1 IF J=1
IF BARCOM(J)="P"
SET BARTYP="P"
GOTO ASKAMT
+2 IF J=1
IF BARCOM(J)="1"
SET BARTYP="P"
GOTO ASKAMT
+3 ; -------------------------------
+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 ; -------------------------------
+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 ; -------------------------------
+5 ;
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)="E"
GOTO ^BARPUC4
+5 WRITE *7," Sorry.. ["_BARHLP(BARCOM(1))_"] not active!"
+6 GOTO ASKCOM
+7 ; *********************************************************************
+8 ;
ASKAMT ;
+1 SET (BARCAT,BARATYP)=""
+2 SET BARASK=$SELECT(BARTYP="P":"Payment ",BARTYP="A":"Adjustment ",1:"")_"Amount: "
+3 SET BARBAL=(BARTX(2)-$GET(BARPMT))
+4 WRITE !,BARASK
+5 IF BARTYP="P"
WRITE $JUSTIFY(BARBAL,0,2)_"// "
+6 READ X:DTIME
+7 IF BARTYP="P"
IF X=""
SET X=+BARBAL
+8 IF BARTYP="P"
SET X=$$AMT^BARPUCU(X,0,BARBAL)
+9 IF BARTYP="A"
SET X=$$AMT^BARPUCU(X)
+10 IF X="^"
GOTO ASKCOM
+11 IF X="?"
WRITE *7," Must be a valid number!"
GOTO ASKAMT
+12 SET BARAMT=X
+13 IF BARTYP="P"
Begin DoDot:1
+14 SET BARCAT=$ORDER(^BAR(90052.01,"B","PAYMENT TYPE",""))
End DoDot:1
GOTO S1
+15 ;
+16 ;** adjustment category/type dialog
+17 SET DIC=90052.01
+18 SET DIC(0)="AEMNQZ"
+19 SET DIC("A")="Adjustment Category: "
+20 SET DIC("S")="I Y=3!(Y=4)!(Y=13)!(Y=14)!(Y=15)!(Y=16)!(Y=20)!(Y=21)!(Y=22)"
+21 KILL DD,DO
+22 DO ^DIC
+23 KILL DIC
+24 IF +Y<0
WRITE *7
KILL BARAMT
WRITE !!
GOTO ASKAMT
+25 SET BARCAT=+Y
+26 IF BARCAT=16
SET BARAMT=-BARAMT
+27 SET BARX=0
SET BARJ=0
+28 KILL BARATYP
+29 FOR
SET BARX=$ORDER(^BARTBL("D",BARCAT,BARX))
IF 'BARX
QUIT
Begin DoDot:1
+30 SET BARJ=BARJ+1
+31 IF BARJ>1
QUIT
+32 SET BARATYP=BARX
End DoDot:1
IF BARJ>1
QUIT
+33 IF BARJ=1
IF $GET(BARATYP)
GOTO S1
+34 SET DIC=90052.02
+35 SET DIC(0)="AEMNQZ"
+36 SET DIC("A")="Adjustment Type: "
+37 SET DIC("S")="I $P(^(0),U,2)=BARCAT"
+38 KILL DD,DO
+39 DO ^DIC
+40 KILL DIC
+41 IF +Y<0
KILL BARAMT
WRITE *7,!!
GOTO ASKAMT
+42 SET BARATYP=+Y
+43 ; -------------------------------
+44 ;
S1 ;
+1 DO SETTMP^BARPUC3A(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP)
+2 GOTO ASKCOM
+3 ; *********************************************************************
+4 ;
COMHLP ;
+1 DO COMHLP^BARPUCU
+2 GOTO ASKCOM1
+3 ; *********************************************************************
+4 ;
FINISH ;
+1 IF '$GET(BARPMT)&('$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 Q ;REWRITTEN ;BAR*1.8*4 DD 4.1.7.2
+4 ;. D POSTTX^BARPUCU
+5 ;. D EN^BARROLL
+6 ;BAR*1.8*4 DD 4.1.7.2
IF BARQ="P"
DO POSTTX^BARPUCU
+7 ;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
+8 ;IS SESSION STILL OPEN
IF $$NOTOPEN^BARUFUT(.DUZ,$GET(UFMSESID))
QUIT
+9 IF $GET(BARSTOP)=1
GOTO FIN
+10 DO EN^BARROLL
+11 KILL ^BARTMP($JOB)
+12 QUIT
+13 ; -------------------------------
+14 ;
POST() ;
P1 ;
+1 DO HIT1^BARPUC2(BARPASS)
+2 DO EOP^BARUTL(2)
+3 ; -------------------------------
+4 ;
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 BARPMT,BARADJ,BARTR
+3 QUIT
