- BARPST3A ; IHS/SD/LSL - PAYMENT COMMAND CNT. ; 05/07/2008
- ;;1.8;IHS ACCOUNTS RECEIVABLE;**3,4,23**;OCT 26, 2005
- ;** A/R posting program
- ; continuation of command processing
- ;
- ; IHS/SD/LSL - 09/23/02 - V1.6 Patch 3 - HIPAA
- ; Don't allow PENDING category to affect balance
- ;
- ; ********************************************************************
- Q
- ;
- SETTMP(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP,BAROAMT) ;EP - store & check amounts; HEAVILY MODIFIED;BAR*1.8*4 DD 4.1.7.2
- ;SEE SETTMPO BELOW FOR ORIGINAL CODE
- K BARFLG("BARWARN")
- S BARSTOP=0
- S BARDA=$O(^BARTMP($J,"B",BARLIN,""))
- Q:BARDA=""
- ; -------------------------------
- B1 ;
- S BARBBAL=$P(^BARTMP($J,BARDA,BARLIN),U,5)
- I BARCAT'=21&(BARCAT'=22) D
- .S BARBBAL=BARBBAL+BAROAMT
- .D CKNEG^BARPST4(BARBBAL,BAROAMT,BARAMT) ;CHECK FOR NEGATIVE BALANCES
- Q:BARSTOP
- I BARTYP="P" D Q:BARSTOP
- .S $P(^BARTMP($J,BARDA,BARLIN),U,6)=$P($G(^BARTMP($J,BARDA,BARLIN)),U,6)+BARAMT
- .S BARPMT=BARPMT+BARAMT
- I BARTYP="A" D Q:BARSTOP
- .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 ;IF PENDING DON'T CHANGE BALANCE
- .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)_U_$G(REVERSAL)_U_$G(REVSCHED) ;IHS/SD/TPF BAR*1.8*4 UFMS SCR56,SCR58
- K BAROAMT,BARBBAL
- 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,BARDIF) ;EP - warner
- I BARLVL=4,'$$IHS^BARUFUT(DUZ(2)) K BARFLG("BARWARN") Q ;BAR*1.8*4 DD 4.1.7.2 P.OTT
- ;;;I BARLVL=4,'$$IHSERA^BARUFUT(DUZ(2)) K BARFLG("BARWARN") Q ;BAR*1.8*4 DD 4.1.7.2 P.OTT
- I '$G(BARFLG("BARWARN")) W !
- W *7,!,"Warning - Posted amount exceeds the "
- W $S(BARLVL=1:"BATCH",BARLVL=2:"ITEM",BARLVL=3:"LOCATION",1:"BILL")_" balance" ;BAR*1.8*4 DD 4.1.7.2
- W " by "_BARDIF_" amount" ;BAR*1.8*4 DD 4.1.7.2
- S BARFLG("BARWARN")=1
- Q
- ;
- ; *********************************************************************
- SETTMPO(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP,BAROAMT) ;EP - store & check amounts;ORIGINAL CODE;BAR*1.8*4
- K BARFLG("BARWARN")
- S BARSTOP=0
- S BARDA=$O(^BARTMP($J,"B",BARLIN,""))
- Q:BARDA=""
- ; -------------------------------
- B1O ;
- S BARBBAL=$P(^BARTMP($J,BARDA,BARLIN),U,5) ;BAR*1.8*4 DD 4.1.7.2
- I BARTYP="P" D Q:BARSTOP
- .I (BARBBAL-BARAMT)<0 D WARN(4,(BARBBAL-BARAMT)) ;BAR*1.8*4 SDD 4.1.7.2
- .I +$G(BAREOB),(BAREOV(4)-(BARPMT+BARAMT))<0 D WARN(3,(BAREOV(4)-(BARPMT+BARAMT)))
- .I (BARITV(19)-(BARPMT+BARAMT))<0 D WARN(2,(BARITV(19)-(BARPMT+BARAMT)))
- .I (BARCLV(17)-(BARPMT+BARAMT))<0 D WARN(1,(BARCLV(17)-(BARPMT+BARAMT)))
- .I $G(BARFLG("BARWARN")) D Q:BARSTOP
- ..K BARFLG("BARWARN")
- ..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
- .S $P(^BARTMP($J,BARDA,BARLIN),U,6)=$P($G(^BARTMP($J,BARDA,BARLIN)),U,6)+BARAMT
- .S BARPMT=BARPMT+BARAMT
- I BARTYP="A" D Q:BARSTOP
- .I (BARBBAL-BARAMT)<0 D WARN(4,(BARBBAL-BARAMT)) ;BAR*1.8*4 SDD 4.1.7.2
- .S $P(^BARTMP($J,BARDA,BARLIN),U,7)=$P($G(^BARTMP($J,BARDA,BARLIN)),U,7)+BARAMT
- .S BARADJ=BARADJ+BARAMT
- S:BARCAT'=21 $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)_U_$G(REVERSAL)_U_$G(REVSCHED) ;IHS/SD/TPF BAR*1.8*4 UFMS SCR56,SCR58
- Q
- ; *********************************************************************
- BARPST3A ; IHS/SD/LSL - PAYMENT COMMAND CNT. ; 05/07/2008
- +1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**3,4,23**;OCT 26, 2005
- +2 ;** A/R posting program
- +3 ; continuation of command processing
- +4 ;
- +5 ; IHS/SD/LSL - 09/23/02 - V1.6 Patch 3 - HIPAA
- +6 ; Don't allow PENDING category to affect balance
- +7 ;
- +8 ; ********************************************************************
- +9 QUIT
- +10 ;
- SETTMP(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP,BAROAMT) ;EP - store & check amounts; HEAVILY MODIFIED;BAR*1.8*4 DD 4.1.7.2
- +1 ;SEE SETTMPO BELOW FOR ORIGINAL CODE
- +2 KILL BARFLG("BARWARN")
- +3 SET BARSTOP=0
- +4 SET BARDA=$ORDER(^BARTMP($JOB,"B",BARLIN,""))
- +5 IF BARDA=""
- QUIT
- +6 ; -------------------------------
- B1 ;
- +1 SET BARBBAL=$PIECE(^BARTMP($JOB,BARDA,BARLIN),U,5)
- +2 IF BARCAT'=21&(BARCAT'=22)
- Begin DoDot:1
- +3 SET BARBBAL=BARBBAL+BAROAMT
- +4 ;CHECK FOR NEGATIVE BALANCES
- DO CKNEG^BARPST4(BARBBAL,BAROAMT,BARAMT)
- End DoDot:1
- +5 IF BARSTOP
- QUIT
- +6 IF BARTYP="P"
- Begin DoDot:1
- +7 SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,6)=$PIECE($GET(^BARTMP($JOB,BARDA,BARLIN)),U,6)+BARAMT
- +8 SET BARPMT=BARPMT+BARAMT
- End DoDot:1
- IF BARSTOP
- QUIT
- +9 IF BARTYP="A"
- Begin DoDot:1
- +10 SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,7)=$PIECE($GET(^BARTMP($JOB,BARDA,BARLIN)),U,7)+BARAMT
- +11 SET BARADJ=BARADJ+BARAMT
- End DoDot:1
- IF BARSTOP
- QUIT
- +12 ;IF PENDING DON'T CHANGE BALANCE
- IF BARCAT'=21&(BARCAT'=22)
- Begin DoDot:1
- +13 SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,5)=$PIECE(^BARTMP($JOB,BARDA,BARLIN),U,5)-BARAMT
- End DoDot:1
- +14 SET BARJ=$ORDER(BARTR(BARLIN,""),-1)
- +15 SET BARJ=BARJ+1
- +16 ;IHS/SD/TPF BAR*1.8*4 UFMS SCR56,SCR58
- SET BARTR(BARLIN,BARJ)=BARTYP_U_BARAMT_U_BARCAT_U_$GET(BARATYP)_U_$GET(REVERSAL)_U_$GET(REVSCHED)
- +17 KILL BAROAMT,BARBBAL
- +18 QUIT
- +19 ; *********************************************************************
- 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,BARDIF) ;EP - warner
- +1 ;BAR*1.8*4 DD 4.1.7.2 P.OTT
- IF BARLVL=4
- IF '$$IHS^BARUFUT(DUZ(2))
- KILL BARFLG("BARWARN")
- QUIT
- +2 ;;;I BARLVL=4,'$$IHSERA^BARUFUT(DUZ(2)) K BARFLG("BARWARN") Q ;BAR*1.8*4 DD 4.1.7.2 P.OTT
- +3 IF '$GET(BARFLG("BARWARN"))
- WRITE !
- +4 WRITE *7,!,"Warning - Posted amount exceeds the "
- +5 ;BAR*1.8*4 DD 4.1.7.2
- WRITE $SELECT(BARLVL=1:"BATCH",BARLVL=2:"ITEM",BARLVL=3:"LOCATION",1:"BILL")_" balance"
- +6 ;BAR*1.8*4 DD 4.1.7.2
- WRITE " by "_BARDIF_" amount"
- +7 SET BARFLG("BARWARN")=1
- +8 QUIT
- +9 ;
- +10 ; *********************************************************************
- SETTMPO(BARTYP,BARAMT,BARLIN,BARCAT,BARATYP,BAROAMT) ;EP - store & check amounts;ORIGINAL CODE;BAR*1.8*4
- +1 KILL BARFLG("BARWARN")
- +2 SET BARSTOP=0
- +3 SET BARDA=$ORDER(^BARTMP($JOB,"B",BARLIN,""))
- +4 IF BARDA=""
- QUIT
- +5 ; -------------------------------
- B1O ;
- +1 ;BAR*1.8*4 DD 4.1.7.2
- SET BARBBAL=$PIECE(^BARTMP($JOB,BARDA,BARLIN),U,5)
- +2 IF BARTYP="P"
- Begin DoDot:1
- +3 ;BAR*1.8*4 SDD 4.1.7.2
- IF (BARBBAL-BARAMT)<0
- DO WARN(4,(BARBBAL-BARAMT))
- +4 IF +$GET(BAREOB)
- IF (BAREOV(4)-(BARPMT+BARAMT))<0
- DO WARN(3,(BAREOV(4)-(BARPMT+BARAMT)))
- +5 IF (BARITV(19)-(BARPMT+BARAMT))<0
- DO WARN(2,(BARITV(19)-(BARPMT+BARAMT)))
- +6 IF (BARCLV(17)-(BARPMT+BARAMT))<0
- DO WARN(1,(BARCLV(17)-(BARPMT+BARAMT)))
- +7 IF $GET(BARFLG("BARWARN"))
- Begin DoDot:2
- +8 KILL BARFLG("BARWARN")
- +9 KILL DIR
- +10 SET DIR(0)="Y"
- +11 SET DIR("A")="ARE YOU SURE"
- +12 SET DIR("B")="NO"
- +13 DO ^DIR
- +14 KILL DIR
- +15 IF Y'=1
- SET BARSTOP=1
- End DoDot:2
- IF BARSTOP
- QUIT
- +16 SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,6)=$PIECE($GET(^BARTMP($JOB,BARDA,BARLIN)),U,6)+BARAMT
- +17 SET BARPMT=BARPMT+BARAMT
- End DoDot:1
- IF BARSTOP
- QUIT
- +18 IF BARTYP="A"
- Begin DoDot:1
- +19 ;BAR*1.8*4 SDD 4.1.7.2
- IF (BARBBAL-BARAMT)<0
- DO WARN(4,(BARBBAL-BARAMT))
- +20 SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,7)=$PIECE($GET(^BARTMP($JOB,BARDA,BARLIN)),U,7)+BARAMT
- +21 SET BARADJ=BARADJ+BARAMT
- End DoDot:1
- IF BARSTOP
- QUIT
- +22 IF BARCAT'=21
- SET $PIECE(^BARTMP($JOB,BARDA,BARLIN),U,5)=$PIECE(^BARTMP($JOB,BARDA,BARLIN),U,5)-BARAMT
- +23 SET BARJ=$ORDER(BARTR(BARLIN,""),-1)
- +24 SET BARJ=BARJ+1
- +25 ;IHS/SD/TPF BAR*1.8*4 UFMS SCR56,SCR58
- SET BARTR(BARLIN,BARJ)=BARTYP_U_BARAMT_U_BARCAT_U_$GET(BARATYP)_U_$GET(REVERSAL)_U_$GET(REVSCHED)
- +26 QUIT
- +27 ; *********************************************************************
