PRCS58CC ;WISC/CLH,PLT - UTILITY CALLS ; 10/13/93 2:19 PM
V ;;5.1;IFCAP;**162**;Oct 20, 2000;Build 2
;Per VHA Directive 2004-038, this routine should not be modified.
;Post payment and close out 1358 when close out flag set
;PRCSX=INT DAILY REF #^INTERNAL DATE/TIME^AMT OF PAYMENT^COMMENTS^COMPLETED FLAG^REFERENCE^SKIP FCP CHECK FLAG
N X,X1,X2,DIC,PRCSDA,PRCSAMT,PRCSNADJ,AUDA,ABAL,BAL1,DA,DR,DIE,PRCSY,DLAYGO
S Y=1 I '$D(PRCSX) S Y=0_U_$P($T(ER+0),";;",2) Q
F I=1:1:3 I $P(PRCSX,U,I)="" S Y=0_U_$P($T(ER+1),";;",2)
I 'Y K PRCSX Q
S PRCSDA=+PRCSX,PRCSAMT=$P(PRCSX,U,3),PRCSY=$G(^PRC(424,PRCSDA,0)) I PRCSY="" S Y=0_U_$P($T(ER+2),";;",2) K PRCSX Q
; if 7th piece = 1, skip fund control point access check PRC*5.1*162
I $P(PRCSX,U,7)'=1,'$D(^PRC(420,+$P(^PRC(424,PRCSDA,0),U),1,+$P(^PRC(442,+$P(PRCSY,U,2),0),U,3),1,DUZ,0)) S Y=0_U_$P($T(ER+4),";;",2) K PRCSX Q
I $P(PRCSY,U,9)=1 S $P(PRCSX,U,5)=1
I $P(PRCSY,U,3)'="AU" S Y=0_U_$P($T(ER+2),";;",2) K PRCSX Q
I PRCSAMT<0,$P(PRCSY,U,5)-$P(PRCSY,U,12)>PRCSAMT S Y=0_U_$P($T(ER+6),";;",2) K PRCSX Q
S Y=0 I $P(PRCSY,U,5)+0<PRCSAMT D I Y S Y=0_U_$P($T(ER+Y),";;",2) K PRCSX Q
. N DA,X,AMT,ABAL,DIFF,BAL,PRCADJ,BAL2,BAL1,AAMT,AUDA,AUDA0
. S BAL=$$BAL^PRCH58($P(PRCSY,U,2)),ABAL=$P(PRCSY,U,5),DIFF=PRCSAMT-ABAL
. I +BAL-$P(BAL,U,3)-DIFF<0 S Y=5 Q
. S PRCADJ=0,AAMT=DIFF,AUDA=PRCSDA,AUDA0=PRCSY D ADJ^PRCEDRE0 I PRCADJ S Y=3 Q
. S DA=AUDA,BAL2=$P($G(^PRC(424,DA,0)),U,12)+DIFF,BAL1=+DIFF,ABAL=ABAL+DIFF,DR=".05////^S X=ABAL;.12////^S X=BAL2",DIE="^PRC(424," D ^DIE
. S PRCSY=^PRC(424,PRCSDA,0)
. D BALUP^PRCH58($P(PRCSY,U,2),BAL1) S Y=0
. QUIT
S Y=1
L +^PRC(424,PRCSDA):5 Q:$T=0 S X=$P(^PRC(424,PRCSDA,0),U,11)+1,$P(^(0),U,11)=X L -^PRC(424,PRCSDA)
S X=$P(PRCSY,U)_"-"_X
S DIC="^PRC(424.1,",DIC(0)="LX",DLAYGO=424.1 D FILE^DICN I Y<0 S Y=0_U_$P($T(ER+7),";;",2) K PRCSX Q
S DA=+Y,DIE="^PRC(424.1,",DR=".02////^S X=PRCSDA;.03///^S X=-PRCSAMT;.04///^S X=""NOW"";.05////^S X=DUZ;.011///^S X=""P"""
S:$P(PRCSX,U,4)]"" DR=DR_";1.1///^S X=$P(PRCSX,U,4);.08///^S X=$P(PRCSX,U,6)" S:$P(PRCSX,U,5)]"" DR=DR_";.07///^S X=$P(PRCSX,U,5)" D ^DIE
S $P(^PRC(424,PRCSDA,0),U,5)=$P($G(^PRC(424,PRCSDA,0)),U,5)-PRCSAMT
;final/complete payment and mark authorization as COMPLETE
I $P(PRCSX,U,5)]"" D
.N AUDA,AAMT,BAL1,AUDA0 S AUDA=PRCSDA,AUDA0=PRCSY
.S X=$G(^PRC(424,AUDA,0)),AAMT=-$P(X,U,5),BAL1=$P(X,U,12)+AAMT,PRCADJ=0 D ADJ^PRCEDRE0 Q:PRCADJ
.S DA=AUDA,DR=".05////^S X=0;.12////^S X=BAL1;.09////^S X=1",DIE="^PRC(424," D ^DIE
.D BALUP^PRCH58($P(PRCSY,U,2),AAMT)
.Q
S Y=1 K PRCSX Q
;
ER ;;No data string passed
;;Data element in string missing
;;Invalid Transaction or Transaction previously closed
;;Authorization amount can't be adjusted.
;;Unauthorized control point user
;;Insufficent obligation funds to adjust authorization to post bill
;;Credit bill amount will exceed total bill amount
;;Unable to create Authorization Line Item
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCS58CC 2967 printed Apr 09, 2024@21:05:30 Page 2
PRCS58CC ;WISC/CLH,PLT - UTILITY CALLS ; 10/13/93 2:19 PM
V ;;5.1;IFCAP;**162**;Oct 20, 2000;Build 2
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;Post payment and close out 1358 when close out flag set
+3 ;PRCSX=INT DAILY REF #^INTERNAL DATE/TIME^AMT OF PAYMENT^COMMENTS^COMPLETED FLAG^REFERENCE^SKIP FCP CHECK FLAG
+4 NEW X,X1,X2,DIC,PRCSDA,PRCSAMT,PRCSNADJ,AUDA,ABAL,BAL1,DA,DR,DIE,PRCSY,DLAYGO
+5 SET Y=1
IF '$DATA(PRCSX)
SET Y=0_U_$PIECE($TEXT(ER+0),";;",2)
QUIT
+6 FOR I=1:1:3
IF $PIECE(PRCSX,U,I)=""
SET Y=0_U_$PIECE($TEXT(ER+1),";;",2)
+7 IF 'Y
KILL PRCSX
QUIT
+8 SET PRCSDA=+PRCSX
SET PRCSAMT=$PIECE(PRCSX,U,3)
SET PRCSY=$GET(^PRC(424,PRCSDA,0))
IF PRCSY=""
SET Y=0_U_$PIECE($TEXT(ER+2),";;",2)
KILL PRCSX
QUIT
+9 ; if 7th piece = 1, skip fund control point access check PRC*5.1*162
+10 IF $PIECE(PRCSX,U,7)'=1
IF '$DATA(^PRC(420,+$PIECE(^PRC(424,PRCSDA,0),U),1,+$PIECE(^PRC(442,+$PIECE(PRCSY,U,2),0),U,3),1,DUZ,0))
SET Y=0_U_$PIECE($TEXT(ER+4),";;",2)
KILL PRCSX
QUIT
+11 IF $PIECE(PRCSY,U,9)=1
SET $PIECE(PRCSX,U,5)=1
+12 IF $PIECE(PRCSY,U,3)'="AU"
SET Y=0_U_$PIECE($TEXT(ER+2),";;",2)
KILL PRCSX
QUIT
+13 IF PRCSAMT<0
IF $PIECE(PRCSY,U,5)-$PIECE(PRCSY,U,12)>PRCSAMT
SET Y=0_U_$PIECE($TEXT(ER+6),";;",2)
KILL PRCSX
QUIT
+14 SET Y=0
IF $PIECE(PRCSY,U,5)+0<PRCSAMT
Begin DoDot:1
+15 NEW DA,X,AMT,ABAL,DIFF,BAL,PRCADJ,BAL2,BAL1,AAMT,AUDA,AUDA0
+16 SET BAL=$$BAL^PRCH58($PIECE(PRCSY,U,2))
SET ABAL=$PIECE(PRCSY,U,5)
SET DIFF=PRCSAMT-ABAL
+17 IF +BAL-$PIECE(BAL,U,3)-DIFF<0
SET Y=5
QUIT
+18 SET PRCADJ=0
SET AAMT=DIFF
SET AUDA=PRCSDA
SET AUDA0=PRCSY
DO ADJ^PRCEDRE0
IF PRCADJ
SET Y=3
QUIT
+19 SET DA=AUDA
SET BAL2=$PIECE($GET(^PRC(424,DA,0)),U,12)+DIFF
SET BAL1=+DIFF
SET ABAL=ABAL+DIFF
SET DR=".05////^S X=ABAL;.12////^S X=BAL2"
SET DIE="^PRC(424,"
DO ^DIE
+20 SET PRCSY=^PRC(424,PRCSDA,0)
+21 DO BALUP^PRCH58($PIECE(PRCSY,U,2),BAL1)
SET Y=0
+22 QUIT
End DoDot:1
IF Y
SET Y=0_U_$PIECE($TEXT(ER+Y),";;",2)
KILL PRCSX
QUIT
+23 SET Y=1
+24 LOCK +^PRC(424,PRCSDA):5
if $TEST=0
QUIT
SET X=$PIECE(^PRC(424,PRCSDA,0),U,11)+1
SET $PIECE(^(0),U,11)=X
LOCK -^PRC(424,PRCSDA)
+25 SET X=$PIECE(PRCSY,U)_"-"_X
+26 SET DIC="^PRC(424.1,"
SET DIC(0)="LX"
SET DLAYGO=424.1
DO FILE^DICN
IF Y<0
SET Y=0_U_$PIECE($TEXT(ER+7),";;",2)
KILL PRCSX
QUIT
+27 SET DA=+Y
SET DIE="^PRC(424.1,"
SET DR=".02////^S X=PRCSDA;.03///^S X=-PRCSAMT;.04///^S X=""NOW"";.05////^S X=DUZ;.011///^S X=""P"""
+28 if $PIECE(PRCSX,U,4)]""
SET DR=DR_";1.1///^S X=$P(PRCSX,U,4);.08///^S X=$P(PRCSX,U,6)"
if $PIECE(PRCSX,U,5)]""
SET DR=DR_";.07///^S X=$P(PRCSX,U,5)"
DO ^DIE
+29 SET $PIECE(^PRC(424,PRCSDA,0),U,5)=$PIECE($GET(^PRC(424,PRCSDA,0)),U,5)-PRCSAMT
+30 ;final/complete payment and mark authorization as COMPLETE
+31 IF $PIECE(PRCSX,U,5)]""
Begin DoDot:1
+32 NEW AUDA,AAMT,BAL1,AUDA0
SET AUDA=PRCSDA
SET AUDA0=PRCSY
+33 SET X=$GET(^PRC(424,AUDA,0))
SET AAMT=-$PIECE(X,U,5)
SET BAL1=$PIECE(X,U,12)+AAMT
SET PRCADJ=0
DO ADJ^PRCEDRE0
if PRCADJ
QUIT
+34 SET DA=AUDA
SET DR=".05////^S X=0;.12////^S X=BAL1;.09////^S X=1"
SET DIE="^PRC(424,"
DO ^DIE
+35 DO BALUP^PRCH58($PIECE(PRCSY,U,2),AAMT)
+36 QUIT
End DoDot:1
+37 SET Y=1
KILL PRCSX
QUIT
+38 ;
ER ;;No data string passed
+1 ;;Data element in string missing
+2 ;;Invalid Transaction or Transaction previously closed
+3 ;;Authorization amount can't be adjusted.
+4 ;;Unauthorized control point user
+5 ;;Insufficent obligation funds to adjust authorization to post bill
+6 ;;Credit bill amount will exceed total bill amount
+7 ;;Unable to create Authorization Line Item
+8 QUIT
