PRCHNPOC ;RB-MNTFW-CONT. OF EDIT PO ;8/7/14 19:48
V ;;5.1;IFCAP;**191**;Oct 20, 2000;Build 4
;Per VA Directive 6402, this routine should not be modified
;
;PRC*5.1*191 Prompt Pay call made from PRCHNPO1 to insure
; ONLY one entry is added/edited with the PP
; field defined as multiple.
;
PPEDIT ;Prompt payment edit
N DIC,DIE,DA,DR,Y,PRCHX,PRCHXX,PRCHVAL,PRCHDA,%X,%Y,PRCHPP
S PRCHPP=$O(^PRC(442,PRCHPO,5,0)) D:PRCHPP
. S (PRCHDA,DA)=PRCHPP
. S DR=".01//^S X=""NET"";1//^S X=30"
. S DA(1)=PRCHPO,DIE="^PRC(442,"_DA(1)_",5," D ^DIE
I 'PRCHPP S DA(1)=PRCHPO,DIC="^PRC(442,"_DA(1)_",5,",DIC(0)="AELQZ",DIC("B")="NET" D ^DIC Q:Y<0 S (PRCHDA,DA)=+Y D
. S $P(^PRC(442,PRCHPO,5,0),U,2)=$P(^DD(442,9.2,0),U,2)
. S DA(1)=PRCHPO,DIE="^PRC(442,"_DA(1)_",5,"
. S DR=".01//^S X=""NET"";1//^S X=30"
. D ^DIE
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHNPOC 861 printed Sep 23, 2025@19:45:08 Page 2
PRCHNPOC ;RB-MNTFW-CONT. OF EDIT PO ;8/7/14 19:48
V ;;5.1;IFCAP;**191**;Oct 20, 2000;Build 4
+1 ;Per VA Directive 6402, this routine should not be modified
+2 ;
+3 ;PRC*5.1*191 Prompt Pay call made from PRCHNPO1 to insure
+4 ; ONLY one entry is added/edited with the PP
+5 ; field defined as multiple.
+6 ;
PPEDIT ;Prompt payment edit
+1 NEW DIC,DIE,DA,DR,Y,PRCHX,PRCHXX,PRCHVAL,PRCHDA,%X,%Y,PRCHPP
+2 SET PRCHPP=$ORDER(^PRC(442,PRCHPO,5,0))
if PRCHPP
Begin DoDot:1
+3 SET (PRCHDA,DA)=PRCHPP
+4 SET DR=".01//^S X=""NET"";1//^S X=30"
+5 SET DA(1)=PRCHPO
SET DIE="^PRC(442,"_DA(1)_",5,"
DO ^DIE
End DoDot:1
+6 IF 'PRCHPP
SET DA(1)=PRCHPO
SET DIC="^PRC(442,"_DA(1)_",5,"
SET DIC(0)="AELQZ"
SET DIC("B")="NET"
DO ^DIC
if Y<0
QUIT
SET (PRCHDA,DA)=+Y
Begin DoDot:1
+7 SET $PIECE(^PRC(442,PRCHPO,5,0),U,2)=$PIECE(^DD(442,9.2,0),U,2)
+8 SET DA(1)=PRCHPO
SET DIE="^PRC(442,"_DA(1)_",5,"
+9 SET DR=".01//^S X=""NET"";1//^S X=30"
+10 DO ^DIE
End DoDot:1
+11 QUIT
