Routine: PRCHCORE

PRCHCORE ;WISC/DJM-CORRECT ESIG #5 ;9/23/94  2:40 PM

V ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 ;THIS CORRECTION ROUTINE WILL RECODE THE ESIG AT FIELD 16.5

 ;IN FILE 442.  THIS WILL ALLOW A VERSION 4 PO TO HAVE MORE

 ;THEN ONE VERSION 5 AMENDMENT.

FIX N PO,PODATE,AMEND,AMEND3,COUNT,CHECKSUM,MESG1

 S PODATE=2931000 F  S PODATE=$O(^PRC(442,"AB",PODATE)) Q:PODATE'>0  Q:PODATE>2940800  S PO=0 F  S PO=$O(^PRC(442,"AB",PODATE,PO)) Q:PO'>0  D

 .S AMEND=$G(^PRC(442,PO,6,0)) Q:AMEND=""

 .S (AMEND,COUNT)=0 F  S AMEND=$O(^PRC(442,PO,6,AMEND)) Q:AMEND'>0  D  Q:COUNT

 ..S AMEND3=$G(^PRC(442,PO,6,AMEND,3,1,0)) Q:AMEND3=""  D  Q

 ...S (CHECKSUM,MESG1)="" D RECODE^PRCHES5(PO,CHECKSUM,.MESG1) S COUNT=1

 ...I MESG1'=1 W !,"The ESIG for PO number "_$P($G(^PRC(442,PO,0)),U)_" did not RECODE correctly."

 ...Q

..Q

.Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHCORE   891     printed  Apr 09, 2024@21:12:17                                                                                                                                                                                                     Page 2

PRCHCORE  ;WISC/DJM-CORRECT ESIG #5 ;9/23/94  2:40 PM

V         ;;5.1;IFCAP;;Oct 20, 2000

 +1       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +2       ;

 +3       ;THIS CORRECTION ROUTINE WILL RECODE THE ESIG AT FIELD 16.5

 +4       ;IN FILE 442.  THIS WILL ALLOW A VERSION 4 PO TO HAVE MORE

 +5       ;THEN ONE VERSION 5 AMENDMENT.

 +6       ;

FIX        NEW PO,PODATE,AMEND,AMEND3,COUNT,CHECKSUM,MESG1

 +1        SET PODATE=2931000

FOR

               SET PODATE=$ORDER(^PRC(442,"AB",PODATE))

               if PODATE'>0

                   QUIT

               if PODATE>2940800

                   QUIT

               SET PO=0

FOR

                   SET PO=$ORDER(^PRC(442,"AB",PODATE,PO))

                   if PO'>0

                       QUIT

                   Begin DoDot:1

 +2                    SET AMEND=$GET(^PRC(442,PO,6,0))

                       if AMEND=""

                           QUIT

 +3                    SET (AMEND,COUNT)=0

FOR

                           SET AMEND=$ORDER(^PRC(442,PO,6,AMEND))

                           if AMEND'>0

                               QUIT

                           Begin DoDot:2

 +4                            SET AMEND3=$GET(^PRC(442,PO,6,AMEND,3,1,0))

                               if AMEND3=""

                                   QUIT

                               Begin DoDot:3

 +5                                SET (CHECKSUM,MESG1)=""

                                   DO RECODE^PRCHES5(PO,CHECKSUM,.MESG1)

                                   SET COUNT=1

 +6                                IF MESG1'=1

                                       WRITE !,"The ESIG for PO number "_$PIECE($GET(^PRC(442,PO,0)),U)_" did not RECODE correctly."

 +7                                QUIT

                               End DoDot:3

                               QUIT

 +8                            QUIT

                           End DoDot:2

                           if COUNT

                               QUIT

 +9                    QUIT

                   End DoDot:1

 +10       QUIT

PRCHCORE.m