- 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 Feb 18, 2025@23:35:27 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