BARPRF3A.m

BARPRF3A ; IHS/SD/LSL - REFUND COMMAND PROCESSING CONTINUED ; 05/07/2008

 ;;1.8;IHS ACCOUNTS RECEIVABLE;**4**;OCT 26, 2005

 ;

 ;** A/R posting program

 ;   continuation of command processing

 ;

 Q

 ; *********************************************************************

 ;

SETTMP(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP) ;EP;BAR*1.8*4 DD 4.1.7.2

 ;HEAVILY MODIFIED SEE SETTMP0 BELOW FOR ORIGNIAL

 K BARFLG("BARWARN")

 S BARSTOP=0

 S BARDA=$O(^BARTMP($J,"B",BARLIN,""))

 S BARBBAL=$P(^BARTMP($J,BARDA,BARLIN),U,5)

 I BARCAT'=21&(BARCAT'=22) D        ;DON'T CHECK BALANCE FOR PENDING/GEN INFO

 .D CKNEG^BARPST4(BARBBAL,0,BARAMT)

 Q:BARSTOP

 I BARTYP="R" D  Q:BARSTOP          ;ADD REFUND TO ADJ FIELD, NOT PAYMENT

 .S $P(^BARTMP($J,BARDA,BARLIN),U,7)=$P($G(^BARTMP($J,BARDA,BARLIN)),U,7)+BARAMT

 .S BARREF=BARREF+BARAMT

 .S BARADJ=BARADJ+BARAMT

 I BARTYP="A" D

 .S $P(^BARTMP($J,BARDA,BARLIN),U,7)=$P($G(^BARTMP($J,BARDA,BARLIN)),U,7)+BARAMT

 .S BARADJ=BARADJ+BARAMT

 I BARCAT'=21&(BARCAT'=22) D

 .S $P(^BARTMP($J,BARDA,BARLIN),U,5)=$P(^BARTMP($J,BARDA,BARLIN),U,5)-BARAMT

 S BARJ=$O(BARTR(BARLIN,""),-1)

 S BARJ=BARJ+1

 S BARTR(BARLIN,BARJ)=BARTYP_U_BARAMT_U_BARCAT_U_$G(BARATYP)

 Q

 ; *********************************************************************

SETTMP0(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP) ;EP;ORIGINAL CODE ;BAR*1.8*4 DD 4.1.7.2

 K BARFLG("BARWARN")

 S BARSTOP=0

 S BARDA=$O(^BARTMP($J,"B",BARLIN,""))

 I BARTYP="R" D  Q:BARSTOP

 .S $P(^BARTMP($J,BARDA,BARLIN),U,6)=$P($G(^BARTMP($J,BARDA,BARLIN)),U,6)+BARAMT

 .S BARREF=BARREF+BARAMT

 I BARTYP="A" D

 .S $P(^BARTMP($J,BARDA,BARLIN),U,7)=$P($G(^BARTMP($J,BARDA,BARLIN)),U,7)+BARAMT

 .S BARADJ=BARADJ+BARAMT

 S $P(^BARTMP($J,BARDA,BARLIN),U,5)=$P(^BARTMP($J,BARDA,BARLIN),U,5)-BARAMT

 S BARJ=$O(BARTR(BARLIN,""),-1)

 S BARJ=BARJ+1

 S BARTR(BARLIN,BARJ)=BARTYP_U_BARAMT_U_BARCAT_U_$G(BARATYP)

 Q

 ;

 ;

HELP ;

 W $$EN^BARVDF("IOF"),!!

 W "Select one of the following: ",!

 W !?5,"P - Post transactions to A/R."

 W !?5,"M - More transaction processing."

 W !?5,"C - Cancel all transactions and start over."

 W !!,"This is a required response - Please select one to proceed!"

 D EOP^BARUTL(1)

 D HIT1^BARPST2(BARPASS),EOP^BARUTL(2)

 Q

 ; *********************************************************************

 ;

WARN(BARLVL)       ;

 W *7,!,"Warning - Posted amount exceeds the "_$S(BARLVL=1:"batch",BARLVL=2:"item",1:"location")_" balance."

 S BARSTOP=1

 D EOP^BARUTL(1)

 Q

SURE ;

 S BARSTOP=0

 K DIR

 S DIR(0)="Y"

 S DIR("A")="ARE YOU SURE"

 S DIR("B")="NO"

 D ^DIR

 K DIR

 I Y'=1 S BARSTOP=1

 Q

SETTMP1(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP) ;EP

 K BARFLG("BARWARN")

 S BARSTOP=0

 S BARDA=$O(^BARTMP($J,"B",BARLIN,""))

 I BARTYP="R" D  Q:BARSTOP

 .S $P(^BARTMP($J,BARDA,BARLIN),U,6)=$P($G(^BARTMP($J,BARDA,BARLIN)),U,6)+BARAMT

 .S BARREF=BARREF+BARAMT

 I BARTYP="A" D

 .S $P(^BARTMP($J,BARDA,BARLIN),U,7)=$P($G(^BARTMP($J,BARDA,BARLIN)),U,7)+BARAMT

 .S BARADJ=BARADJ+BARAMT

 S $P(^BARTMP($J,BARDA,BARLIN),U,5)=$P(^BARTMP($J,BARDA,BARLIN),U,5)-BARAMT

 S BARJ=$O(BARTR(BARLIN,""),-1)

 S BARJ=BARJ+1

 S BARTR(BARLIN,BARJ)=BARTYP_U_BARAMT_U_BARCAT_U_$G(BARATYP)

 Q

BARPRF3A  ; IHS/SD/LSL - REFUND COMMAND PROCESSING CONTINUED ; 05/07/2008

 +1       ;;1.8;IHS ACCOUNTS RECEIVABLE;**4**;OCT 26, 2005

 +2       ;

 +3       ;** A/R posting program

 +4       ;   continuation of command processing

 +5       ;

 +6        QUIT 

 +7       ; *********************************************************************

 +8       ;

SETTMP(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP) ;EP;BAR*1.8*4 DD 4.1.7.2

 +1       ;HEAVILY MODIFIED SEE SETTMP0 BELOW FOR ORIGNIAL

 +2        KILL BARFLG("BARWARN")

 +3        SET BARSTOP=0

 +4        SET BARDA=$ORDER(^BARTMP($JOB,"B",BARLIN,""))

 +5        SET BARBBAL=$PIECE(^BARTMP($JOB,BARDA,BARLIN),U,5)

 +6       ;DON'T CHECK BALANCE FOR PENDING/GEN INFO

           IF BARCAT'=21&(BARCAT'=22)

               Begin DoDot:1

 +7                DO CKNEG^BARPST4(BARBBAL,0,BARAMT)

               End DoDot:1

 +8        IF BARSTOP

               QUIT 

 +9       ;ADD REFUND TO ADJ FIELD, NOT PAYMENT

           IF BARTYP="R"

               Begin DoDot:1

 +10               SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,7)=$PIECE($GET(^BARTMP($JOB,BARDA,BARLIN)),U,7)+BARAMT

 +11               SET BARREF=BARREF+BARAMT

 +12               SET BARADJ=BARADJ+BARAMT

               End DoDot:1

               IF BARSTOP

                   QUIT 

 +13       IF BARTYP="A"

               Begin DoDot:1

 +14               SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,7)=$PIECE($GET(^BARTMP($JOB,BARDA,BARLIN)),U,7)+BARAMT

 +15               SET BARADJ=BARADJ+BARAMT

               End DoDot:1

 +16       IF BARCAT'=21&(BARCAT'=22)

               Begin DoDot:1

 +17               SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,5)=$PIECE(^BARTMP($JOB,BARDA,BARLIN),U,5)-BARAMT

               End DoDot:1

 +18       SET BARJ=$ORDER(BARTR(BARLIN,""),-1)

 +19       SET BARJ=BARJ+1

 +20       SET BARTR(BARLIN,BARJ)=BARTYP_U_BARAMT_U_BARCAT_U_$GET(BARATYP)

 +21       QUIT 

 +22      ; *********************************************************************

SETTMP0(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP) ;EP;ORIGINAL CODE ;BAR*1.8*4 DD 4.1.7.2

 +1        KILL BARFLG("BARWARN")

 +2        SET BARSTOP=0

 +3        SET BARDA=$ORDER(^BARTMP($JOB,"B",BARLIN,""))

 +4        IF BARTYP="R"

               Begin DoDot:1

 +5                SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,6)=$PIECE($GET(^BARTMP($JOB,BARDA,BARLIN)),U,6)+BARAMT

 +6                SET BARREF=BARREF+BARAMT

               End DoDot:1

               IF BARSTOP

                   QUIT 

 +7        IF BARTYP="A"

               Begin DoDot:1

 +8                SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,7)=$PIECE($GET(^BARTMP($JOB,BARDA,BARLIN)),U,7)+BARAMT

 +9                SET BARADJ=BARADJ+BARAMT

               End DoDot:1

 +10       SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,5)=$PIECE(^BARTMP($JOB,BARDA,BARLIN),U,5)-BARAMT

 +11       SET BARJ=$ORDER(BARTR(BARLIN,""),-1)

 +12       SET BARJ=BARJ+1

 +13       SET BARTR(BARLIN,BARJ)=BARTYP_U_BARAMT_U_BARCAT_U_$GET(BARATYP)

 +14       QUIT 

 +15      ;

 +16      ;

HELP      ;

 +1        WRITE $$EN^BARVDF("IOF"),!!

 +2        WRITE "Select one of the following: ",!

 +3        WRITE !?5,"P - Post transactions to A/R."

 +4        WRITE !?5,"M - More transaction processing."

 +5        WRITE !?5,"C - Cancel all transactions and start over."

 +6        WRITE !!,"This is a required response - Please select one to proceed!"

 +7        DO EOP^BARUTL(1)

 +8        DO HIT1^BARPST2(BARPASS)

           DO EOP^BARUTL(2)

 +9        QUIT 

 +10      ; *********************************************************************

 +11      ;

WARN(BARLVL) ;

 +1        WRITE *7,!,"Warning - Posted amount exceeds the "_$SELECT(BARLVL=1:"batch",BARLVL=2:"item",1:"location")_" balance."

 +2        SET BARSTOP=1

 +3        DO EOP^BARUTL(1)

 +4        QUIT 

SURE      ;

 +1        SET BARSTOP=0

 +2        KILL DIR

 +3        SET DIR(0)="Y"

 +4        SET DIR("A")="ARE YOU SURE"

 +5        SET DIR("B")="NO"

 +6        DO ^DIR

 +7        KILL DIR

 +8        IF Y'=1

               SET BARSTOP=1

 +9        QUIT 

SETTMP1(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP) ;EP

 +1        KILL BARFLG("BARWARN")

 +2        SET BARSTOP=0

 +3        SET BARDA=$ORDER(^BARTMP($JOB,"B",BARLIN,""))

 +4        IF BARTYP="R"

               Begin DoDot:1

 +5                SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,6)=$PIECE($GET(^BARTMP($JOB,BARDA,BARLIN)),U,6)+BARAMT

 +6                SET BARREF=BARREF+BARAMT

               End DoDot:1

               IF BARSTOP

                   QUIT 

 +7        IF BARTYP="A"

               Begin DoDot:1

 +8                SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,7)=$PIECE($GET(^BARTMP($JOB,BARDA,BARLIN)),U,7)+BARAMT

 +9                SET BARADJ=BARADJ+BARAMT

               End DoDot:1

 +10       SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,5)=$PIECE(^BARTMP($JOB,BARDA,BARLIN),U,5)-BARAMT

 +11       SET BARJ=$ORDER(BARTR(BARLIN,""),-1)

 +12       SET BARJ=BARJ+1

 +13       SET BARTR(BARLIN,BARJ)=BARTYP_U_BARAMT_U_BARCAT_U_$GET(BARATYP)

 +14       QUIT