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

PRCS58CC.m

Go to the documentation of this file.
  1. PRCS58CC ;WISC/CLH,PLT - UTILITY CALLS ; 10/13/93 2:19 PM
  1. V ;;5.1;IFCAP;**162**;Oct 20, 2000;Build 2
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;Post payment and close out 1358 when close out flag set
  1. ;PRCSX=INT DAILY REF #^INTERNAL DATE/TIME^AMT OF PAYMENT^COMMENTS^COMPLETED FLAG^REFERENCE^SKIP FCP CHECK FLAG
  1. N X,X1,X2,DIC,PRCSDA,PRCSAMT,PRCSNADJ,AUDA,ABAL,BAL1,DA,DR,DIE,PRCSY,DLAYGO
  1. S Y=1 I '$D(PRCSX) S Y=0_U_$P($T(ER+0),";;",2) Q
  1. F I=1:1:3 I $P(PRCSX,U,I)="" S Y=0_U_$P($T(ER+1),";;",2)
  1. I 'Y K PRCSX Q
  1. 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
  1. ; if 7th piece = 1, skip fund control point access check PRC*5.1*162
  1. 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
  1. I $P(PRCSY,U,9)=1 S $P(PRCSX,U,5)=1
  1. I $P(PRCSY,U,3)'="AU" S Y=0_U_$P($T(ER+2),";;",2) K PRCSX Q
  1. I PRCSAMT<0,$P(PRCSY,U,5)-$P(PRCSY,U,12)>PRCSAMT S Y=0_U_$P($T(ER+6),";;",2) K PRCSX Q
  1. 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
  1. . N DA,X,AMT,ABAL,DIFF,BAL,PRCADJ,BAL2,BAL1,AAMT,AUDA,AUDA0
  1. . S BAL=$$BAL^PRCH58($P(PRCSY,U,2)),ABAL=$P(PRCSY,U,5),DIFF=PRCSAMT-ABAL
  1. . I +BAL-$P(BAL,U,3)-DIFF<0 S Y=5 Q
  1. . S PRCADJ=0,AAMT=DIFF,AUDA=PRCSDA,AUDA0=PRCSY D ADJ^PRCEDRE0 I PRCADJ S Y=3 Q
  1. . 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
  1. . S PRCSY=^PRC(424,PRCSDA,0)
  1. . D BALUP^PRCH58($P(PRCSY,U,2),BAL1) S Y=0
  1. . QUIT
  1. S Y=1
  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)
  1. S X=$P(PRCSY,U)_"-"_X
  1. 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
  1. 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"""
  1. 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
  1. S $P(^PRC(424,PRCSDA,0),U,5)=$P($G(^PRC(424,PRCSDA,0)),U,5)-PRCSAMT
  1. ;final/complete payment and mark authorization as COMPLETE
  1. I $P(PRCSX,U,5)]"" D
  1. .N AUDA,AAMT,BAL1,AUDA0 S AUDA=PRCSDA,AUDA0=PRCSY
  1. .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
  1. .S DA=AUDA,DR=".05////^S X=0;.12////^S X=BAL1;.09////^S X=1",DIE="^PRC(424," D ^DIE
  1. .D BALUP^PRCH58($P(PRCSY,U,2),AAMT)
  1. .Q
  1. S Y=1 K PRCSX Q
  1. ;
  1. ER ;;No data string passed
  1. ;;Data element in string missing
  1. ;;Invalid Transaction or Transaction previously closed
  1. ;;Authorization amount can't be adjusted.
  1. ;;Unauthorized control point user
  1. ;;Insufficent obligation funds to adjust authorization to post bill
  1. ;;Credit bill amount will exceed total bill amount
  1. ;;Unable to create Authorization Line Item
  1. Q