- 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 Jan 18, 2025@03:18:19 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