Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BARPNP3

BARPNP3.m

Go to the documentation of this file. 
  1. 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
  1.  ;** 'Select Command' processor
  1.  ;
  1.  ; IHS/SD/LSL - 09/23/02 - V1.6 Patch 3 - HIPAA
  1.  ;     Allow user to select new Adjustment Categories PENDING
  1.  ;     or GENERAL INFORMATION
  1.  ;
  1.  ; IHS/SD/SDR - 10/18/02 - V1.7 - OEA-1002-190010
  1.  ;      Resolve <UNDEF> PARSE+6^XBDIQ1
  1.  ;
  1.  ; IHS/SD/LS - 10/17/03 - V1.7 Patch 4
  1.  ;      Allow rollover even if previously rolled.
  1.  ;
  1.  ; IHS/SD/POT - NOHEAT 03/31/14 - BAR*1.8*24 LIMIT INPUT LENGTH
  1.  ; ********************************************************************
  1.  ;
  1. EN ;EP - posting command handler
  1.  K DIR,BARTR
  1.  K ^TEMP($J,"BARPOST")
  1.  S (BARADJ,BARPMT)=0
  1.  S BARDFLT=""
  1.  W !!
  1.  ; -------------------------------
  1.  ;
  1. EN1 ;
  1.  K BARCOM,BARTYP,BARCAT,BARATYP,BARAMT,BARLIN
  1.  S BARDSP=1
  1.  D HIT1^BARPNP2(BARPASS)
  1.  ; -------------------------------
  1.  ;
  1. EN2 ;
  1.  W !!
  1.  K BARCOM,BARAMT
  1.  D:$D(BARHLP)<10 SETHLP^BARPNPU
  1.  ; -------------------------------
  1.  ;
  1. ASKLIN ;
  1.  I BARCNT=1 S (BARLIN,BARDFLT)=1 G ASKCOM1
  1.  D ASKLIN^BARFPST3
  1.  I $G(BARLIN)["^" G FINISH
  1.  I $G(BARLIN)=0 G FINISH
  1.  I BARLIN>0,BARLIN<(BARCNT+1) G ASKCOM1
  1.  ; -------------------------------
  1.  ;
  1. LNHLP ;
  1.  ;
  1. ASKCOM ;EP - select command
  1.  K BARCOM,BARTYP,BARCAT,BARATYP,BARAMT
  1.  S BARDSP=1
  1.  D HIT1^BARPNP2(BARPASS)
  1.  W !
  1.  ; -------------------------------
  1.  ;
  1. ASKCOM1 ;
  1.  I $$NOTOPEN^BARUFUT(.DUZ,$G(UFMSESID)) Q  ;IS SESSION STILL OPEN
  1.  W !,"Select Command (Line # "_BARLIN_") : "
  1.  ;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
  1.  R BARCOM:DTIME
  1.  S BARCOM=$E(BARCOM,1,10) ;BAR*1.8*24
  1.  S BARCOM=$$UPC^BARUTL(BARCOM)
  1.  ;start new code IHS/SD/SDR bar*1.8*4 DD item 4.1.7.1
  1.  I ("P1A2"[BARCOM) D  I $D(DIROUT)!$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!($G(Y)=0) G ASKCOM
  1.  .S BARBLDA=$O(^BARTMP($J,"B",BARLIN,""))
  1.  .S BARTPB=$$FIND3PB^BARUTL(DUZ(2),BARBLDA)
  1.  .K DIROUT,DIRUT,DTOUT,DUOUT
  1.  .K DIR,DIE,DIC,X,Y,DA,DR
  1.  .Q:$G(BARTPB)=""
  1.  .S BARSTAT=$P($G(^ABMDBILL($P(BARTPB,","),$P(BARTPB,",",2),0)),U,4)
  1.  .Q:BARSTAT'="X"
  1.  .W !!,"STOP!  3P BILL ",$P($P($G(^BARBL(DUZ(2),BARBLDA,0)),U),"-")," has been cancelled."
  1.  .S DIR(0)="Y"
  1.  .S DIR("A")="Are you sure you want to post to this invoice"
  1.  .S DIR("B")="N"
  1.  .D ^DIR K DIR
  1.  ;end new code IHS/SD/SDR bar*1.8*4 DD item 4.1.7.1
  1.  S Q=0
  1.  F J=1:1 D  Q:Q
  1.  .S BARCOM(J)=$P(BARCOM,",",J)
  1.  .Q:$L(BARCOM(J))
  1.  .K BARCOM(J)
  1.  .S J=J-1
  1.  .S Q=1 Q
  1.  I 'J!($L($G(BARCOM(1)))=0) G ASKCOM
  1.  I BARCOM(1)=2 S BARCOM(1)="A" W *7,*7,*7
  1.  I BARCOM(1)=3 S BARCOM(1)="Q" W *7,*7,*7
  1.  I '$D(BARHLP(BARCOM(1))) G COMHLP
  1.  I J=1,BARCOM(J)="M" D  G ASKCOM
  1.  .N DA,DIC,BARBLDA,BARACC
  1.  .S BARBLDA=$O(^BARTMP($J,"B",BARLIN,""))
  1.  .S BARACC=$$GET1^DIQ(90050.01,BARBLDA,3,"I")
  1.  .D EN^BARPST6(BARPAT,BARBLDA,BARACC)
  1.  .Q
  1.  I J=1,BARCOM(J)="T" D  G ASKCOM
  1.  .S Y=$$DSPLY^BARPNP4(BARLIN)
  1.  .D EOP^BARUTL(1)
  1.  I J=1,BARCOM(J)="H" D HISTORY^BARBAD3 G ASKCOM
  1.  I J=1,BARCOM(J)="R" D ROLL G ASKCOM
  1.  ;
  1.  ;enable posting rollback
  1. GOQ ;
  1.  ;I J=1,BARCOM(J)="Q" G:BARCNT>1 EN1 G FINISH    ;BAR*1.8*4 DD 4.1.7.2
  1.  I J=1,BARCOM(J)="Q" D  G:BARCNT>1 EN1 G FINISH  ;BAR*1.8*4 DD 4.1.7.2
  1.  .D CKNEG^BARPST3(BARLIN)                        ;BAR*1.8*4 DD 4.1.7.2
  1.  ;
  1. GOA ;
  1.  I J=1,BARCOM(J)="A" S BARTYP="A" G ASKAMT
  1.  I J=1,BARCOM(J)="2" S BARTYP="A" G ASKAMT
  1.  I J=1,BARCOM(J)="E" G ^BARPNP4
  1.  ;
  1. GOD ;
  1.  I J=1,BARCOM(J)="D" D  G ASKCOM
  1.  . S DFN=BARPAT
  1.  . D VIEWR^XBLM("START^AGFACE")
  1.  ;
  1. GOB ;
  1.  I J=1,BARCOM(J)="B" D  G ASKCOM
  1.  . S BARBLDA=$O(^BARTMP($J,"B",BARLIN,""))
  1.  . D DIQ^XBLM(90050.01,BARBLDA)
  1.  W *7,!,"   Sorry.. ["_BARHLP(BARCOM(1))_"] not active!"
  1.  D EOP^BARUTL(1)
  1.  G ASKCOM
  1.  ; *********************************************************************
  1.  ;
  1. ASKAMT ;
  1.  S (BARCAT,BARATYP)=""
  1.  S BARASK=$S(BARTYP="P":"Payment ",BARTYP="A":"Adjustment ",1:"")_"Amount: "
  1.  W !,BARASK R X:DTIME
  1.  S X=$$AMT^BARPNPU(X)
  1.  I X="^" G ASKCOM
  1.  I X="?" W *7,"  Must be a valid number!" G ASKAMT
  1.  S BARAMT=X
  1.  I BARTYP="P" D  G S1
  1.  . S BARCAT=$O(^BAR(90052.01,"B","PAYMENT TYPE",""))
  1.  . Q
  1.  ;
  1.  ;** adjustment category/type dialog
  1.  S DIC=90052.01
  1.  S DIC(0)="AEMNQZ"
  1.  S DIC("A")="Adjustment Category: "
  1.  S DIC("S")="I "",3,4,13,14,15,16,20,21,22,""[("",""_Y_"","")"
  1.  D ^DIC
  1.  K DIC
  1.  I +Y<0 W *7 K BARAMT W !! G ASKAMT
  1.  S BARCAT=+Y
  1.  S:BARCAT=16 BARAMT=-BARAMT ;grouper
  1.  S BARX=0,BARJ=0
  1.  K BARATYP
  1.  F  S BARX=$O(^BARTBL("D",BARCAT,BARX)) Q:'BARX  D  Q:BARJ>1
  1.  .S BARJ=BARJ+1
  1.  .Q:BARJ>1
  1.  .S BARATYP=BARX
  1.  I BARJ=1,$G(BARATYP) G S1
  1.  S DIC=90052.02
  1.  S DIC(0)="AEMNQZ"
  1.  S DIC("A")="Adjustment Type: "
  1.  S DIC("S")="I $P(^(0),U,2)=BARCAT"
  1.  D ^DIC
  1.  K DIC
  1.  I +Y<0 K BARAMT W *7,!! G ASKAMT
  1.  S BARATYP=+Y
  1.  ; -------------------------------
  1.  ;
  1. S1 ;
  1.  ;D SETTMP^BARPST3A(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP)  ;BAR*1.8*4 DD 4.1.7.2
  1.  D SETTMP^BARPST3A(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP,0)  ;BAR*1.8*4 DD 4.1.7.2
  1.  G ASKCOM
  1.  ; *********************************************************************
  1.  ;
  1. COMHLP ;
  1.  D COMHLP^BARPNPU
  1.  G ASKCOM1
  1.  ; *********************************************************************
  1.  ;
  1. FINISH ;
  1.  I '$G(BARPMT)&('$G(BARADJ))&'$D(BARROLL)&'$D(BARTR) D CANCEL Q
  1.  ; enable posting rollback
  1.  ;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
  1.  I $$NOTOPEN^BARUFUT(.DUZ,$G(UFMSESID)) D CANCEL Q  ;IS SESSION STILL OPEN
  1. FIN S BARQ=$$POST()                            ;BAR*1.8*4 DD 4.1.7.2
  1.  I BARQ="M" G EN1
  1.  I BARQ="C" D CANCEL Q
  1.  ;I BARQ="P" D POSTTX^BARPNPU,EN^BARROLL Q  ;BAR*1.8*4 DD 4.1.7.2
  1.  I BARQ="P" K BARCOL D POSTTX^BARPSTU       ;BAR*1.8*4 DD 4.1.7.2 
  1.  I $G(BARSTOP)=1 G FIN                      ;BAR*1.8*4 DD 4.1.7.2
  1.  D EN^BARROLL
  1.  K ^BARTMP($J)                              ;BAR*1.8*4 DD 4.1.7.2
  1.  Q
  1.  ; -------------------------------
  1.  ;
  1. POST() ;
  1. P1 ;
  1.  D HIT1^BARPNP2(BARPASS)
  1.  D EOP^BARUTL(2)
  1.  ;
  1. PDIR K DIR
  1.  S DIR(0)="SAO^P:POST TO A/R;M:MORE;C:CANCEL"
  1.  S DIR("A")="Select Action (P/M/C): "
  1.  D ^DIR
  1.  K DIR
  1.  I $D(DUOUT)!(Y="") W *7 G PDIR
  1.  Q Y
  1.  ; *********************************************************************
  1.  ;
  1. ROLL ;EP - tag a bill for rollback to 3P
  1.  ; enable posting rollback
  1.  N BARBLDA
  1.  S BARBLDA=$O(^BARTMP($J,"B",BARLIN,""))
  1.  S BARROLL(BARBLDA)=""
  1.  K DIC,DIE
  1.  S DIE="^BARBL(DUZ(2),"
  1.  S DA=BARBLDA
  1.  S DR="214///@"
  1.  D ^DIE
  1.  K DIC,DIE,X,Y,DR
  1.  K DIR
  1.  S DIR("A")="TAGGED for Rolling. Enter RETURN to Continue."
  1.  D EOP^BARUTL(0)
  1. ROLLE ;
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. CANCEL ;
  1.  K ^BARTMP($J)
  1.  K BARPMT,BARADJ,BARTR
  1.  Q