PRCHNPOC.m

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 ---PRCHNPOC   861     printed  Apr 09, 2024@21:19:32                                                                                                                                                                                                     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