PRCIREC.m

PRCIREC ;WISC/SWS-PRCIREC continued ;9/7/06  14:22

V ;;5.1;IFCAP;**113,149**;Oct 20, 2000;Build 5

 ;Per VHA Directive 2004-038, this routine should not be modified.

 ;This routine serves as the input transform for the field Final Charge in File ^PRCH(440.6

 ;PRC*5.1*149 checks the 'PO' index in file 440.6 as the check for order number in 'C' x-ref was not valid order number, but charge returned order info

 Q

START S MYIEN=$P($G(^PRCH(440.6,DA,1)),U) S:'MYIEN MYIEN=$G(PRCRI(442))

 I '$G(MYIEN) Q

 S VALUE2=MYIEN,VALUE3=0,BFLAG=0

 F  S VALUE3=$O(^PRCH(440.6,"PO",VALUE2,VALUE3)) Q:'VALUE3!(BFLAG=1)  D

 .I VALUE3'=DA D

 ..I $P($G(^PRCH(440.6,VALUE3,1)),U,4)="Y" D

 ...S BFLAG=1

 ...K MSG

 ...S MSG(1)="Sorry, there is already a final charge for this PC Order."

 ...S MSG(2)="You need to edit or remove the first final charge to continue."

 ...S MSG(2,"F")="!"

 ...S MSG(3)=""

 ...S MSG(3,"F")="!"

 ...D EN^DDIOL(.MSG)

 ...K MSG,X

 ...S BFLAG=1

 K BFLAG

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCIREC   983     printed  Mar 13, 2025@21:16:19                                                                                                                                                                                                      Page 2

PRCIREC   ;WISC/SWS-PRCIREC continued ;9/7/06  14:22

V         ;;5.1;IFCAP;**113,149**;Oct 20, 2000;Build 5

 +1       ;Per VHA Directive 2004-038, this routine should not be modified.

 +2       ;This routine serves as the input transform for the field Final Charge in File ^PRCH(440.6

 +3       ;PRC*5.1*149 checks the 'PO' index in file 440.6 as the check for order number in 'C' x-ref was not valid order number, but charge returned order info

 +4        QUIT 

START      SET MYIEN=$PIECE($GET(^PRCH(440.6,DA,1)),U)

           if 'MYIEN

               SET MYIEN=$GET(PRCRI(442))

 +1        IF '$GET(MYIEN)

               QUIT 

 +2        SET VALUE2=MYIEN

           SET VALUE3=0

           SET BFLAG=0

 +3        FOR 

               SET VALUE3=$ORDER(^PRCH(440.6,"PO",VALUE2,VALUE3))

               if 'VALUE3!(BFLAG=1)

                   QUIT 

               Begin DoDot:1

 +4                IF VALUE3'=DA

                       Begin DoDot:2

 +5                        IF $PIECE($GET(^PRCH(440.6,VALUE3,1)),U,4)="Y"

                               Begin DoDot:3

 +6                                SET BFLAG=1

 +7                                KILL MSG

 +8                                SET MSG(1)="Sorry, there is already a final charge for this PC Order."

 +9                                SET MSG(2)="You need to edit or remove the first final charge to continue."

 +10                               SET MSG(2,"F")="!"

 +11                               SET MSG(3)=""

 +12                               SET MSG(3,"F")="!"

 +13                               DO EN^DDIOL(.MSG)

 +14                               KILL MSG,X

 +15                               SET BFLAG=1

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +16       KILL BFLAG

 +17       QUIT