PRCF223P.m

PRCF223P ;MNTVBB/RGB - Cleanse Receiving queue of partial sets and update Authority file (410.9) ; 01/10/21@12:05

V ;;5.1;IFCAP;**223**;Jan 10, 2021;Build 16

 ;Per VA Directive 6402, this routine should not be modified.

 ;

 Q

START ;PRC*5.1*223 Updating file 410.9 [Authority of Request File] with new

 ;            sub authority 'Q', 'FRANCHISE FUND: VTP CLAIMS'

 D CLEAN1  ;Cleanse Receiving Report of incomplete filed transmission

 D SETAO  ;Set missing 'AO' index in file 410, field 4

 D UPDATE ;Update AUTHORITY OF REQUEST file

 Q

UPDATE ;Update Authority file 410.9

 N DIE,DA,DR,PRCI,PRCX,PRCIEN,PRCCD,PRCSUB,PRCDESC

 S U="^"

 S DIE="^PRCS(410.9,"

 F PRCI=1:1 S PRCX=$P($T(ADD+PRCI),";",3) Q:PRCX="QUIT"  D

 . S X=$P(PRCX,U,2),DLAYGO=410.9,DIC="^PRCS(410.9,",DIC(0)="LXZ" D ^DIC K DLAYGO G:Y<0 ERR

 . S (DA,PRCIEN)=+Y,PRCCD=$P(Y,U,2),PRCSUB=$P(PRCX,"^"),PRCDESC=$P(PRCX,"^",3)

 . S DR=".02///^S X=PRCDESC;.03///^S X=PRCSUB;.05///^S X=1;.06///^S X=1;.07///^S X=PRCSUB_PRCCD"

 . D ^DIE

 . D MES^XPDUTL("Updating Authority of Request Code "_PRCCD_PRCSUB_" - "_PRCDESC)

 D MES^XPDUTL(""),BMES^XPDUTL("**Update of Authority of Request File completed**")

 K DIC,X,Y

 Q

ADD ;;

 ;;3^Q^FRANCHISE FUND: VTP Claims

 ;;QUIT

ERR ;File add messed up!!

 ;

CLEAN1 ;Cleanse (FILE 442) fiscal signed receipts transmitted, but not filed correctly.

 N PRCIEN,PRCPART,PRCRECPT,PRCTOT

 K ^XTMP("PRCF223P")

 S ^XTMP("PRCF223P",0)=$$FMADD^XLFDT(DT,90)_"^"_DT

 S ^XTMP("PRCF223P",$J,0)="0"

 S (PRCIEN,PRCTOT)=0

A S PRCIEN=$O(^PRC(442,PRCIEN)),PRCPART=0 I 'PRCIEN G ZZ

A1 S PRCPART=$O(^PRC(442,PRCIEN,11,PRCPART)) I 'PRCPART G A

 S PRCRECPT=$G(^PRC(442,PRCIEN,11,PRCPART,0)) Q:PRCRECPT=""

 I $P(PRCRECPT,U,19)'["RR" G A1

 I $P(PRCRECPT,U,6)'="" G A1

 S ^XTMP("PRCF223P",$J,1,PRCIEN,11,PRCPART,0)=PRCRECPT,PRCTOT=PRCTOT+1

 S $P(^PRC(442,PRCIEN,11,PRCPART,0),U,6)="Y"

 ;W !!,PRCIEN,?12,$P(^PRC(442,PRCIEN,0),U),!,PRCRECPT

 G A1

ZZ S ^XTMP("PRCF223P",$J,1,0)=PRCTOT

 D MES^XPDUTL(""),BMES^XPDUTL("**Cleansing of Receiving Report completed: "_PRCTOT_" RESETS **")

 Q

SETAO ;Set 'AO' index for invalid sets in file 410, field 4 from routine PRCSEB

 N PRCSIEN,PRCTOT

B S (PRCSIEN,PRCTOT)=0

B1 S PRCSIEN=$O(^PRCS(410,PRCSIEN)) G BQ:'PRCSIEN

 S PRCSIP=$P($G(^PRCS(410,PRCSIEN,0)),U,6) G:'PRCSIP B1

 I $D(^PRCS(410,"AO",PRCSIP,PRCSIEN)) G B1

 S ^PRCS(410,"AO",PRCSIP,PRCSIEN)="",^XTMP("PRCF223P",$J,2,PRCSIEN,0)=PRCSIP

 ;W !,PRCSIEN,?15,PRCSIP

 S PRCTOT=PRCTOT+1

 G B1

BQ S ^XTMP("PRCF223P",$J,2,0)=PRCTOT

 D MES^XPDUTL(""),BMES^XPDUTL("** File 410, 'AO' index reset completed: "_PRCTOT_" RESETS **")

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCF223P   2635     printed  Mar 13, 2025@21:06:28                                                                                                                                                                                                    Page 2

PRCF223P  ;MNTVBB/RGB - Cleanse Receiving queue of partial sets and update Authority file (410.9) ; 01/10/21@12:05

V         ;;5.1;IFCAP;**223**;Jan 10, 2021;Build 16

 +1       ;Per VA Directive 6402, this routine should not be modified.

 +2       ;

 +3        QUIT 

START     ;PRC*5.1*223 Updating file 410.9 [Authority of Request File] with new

 +1       ;            sub authority 'Q', 'FRANCHISE FUND: VTP CLAIMS'

 +2       ;Cleanse Receiving Report of incomplete filed transmission

           DO CLEAN1

 +3       ;Set missing 'AO' index in file 410, field 4

           DO SETAO

 +4       ;Update AUTHORITY OF REQUEST file

           DO UPDATE

 +5        QUIT 

UPDATE    ;Update Authority file 410.9

 +1        NEW DIE,DA,DR,PRCI,PRCX,PRCIEN,PRCCD,PRCSUB,PRCDESC

 +2        SET U="^"

 +3        SET DIE="^PRCS(410.9,"

 +4        FOR PRCI=1:1

               SET PRCX=$PIECE($TEXT(ADD+PRCI),";",3)

               if PRCX="QUIT"

                   QUIT 

               Begin DoDot:1

 +5                SET X=$PIECE(PRCX,U,2)

                   SET DLAYGO=410.9

                   SET DIC="^PRCS(410.9,"

                   SET DIC(0)="LXZ"

                   DO ^DIC

                   KILL DLAYGO

                   if Y<0

                       GOTO ERR

 +6                SET (DA,PRCIEN)=+Y

                   SET PRCCD=$PIECE(Y,U,2)

                   SET PRCSUB=$PIECE(PRCX,"^")

                   SET PRCDESC=$PIECE(PRCX,"^",3)

 +7                SET DR=".02///^S X=PRCDESC;.03///^S X=PRCSUB;.05///^S X=1;.06///^S X=1;.07///^S X=PRCSUB_PRCCD"

 +8                DO ^DIE

 +9                DO MES^XPDUTL("Updating Authority of Request Code "_PRCCD_PRCSUB_" - "_PRCDESC)

               End DoDot:1

 +10       DO MES^XPDUTL("")

           DO BMES^XPDUTL("**Update of Authority of Request File completed**")

 +11       KILL DIC,X,Y

 +12       QUIT 

ADD       ;;

 +1       ;;3^Q^FRANCHISE FUND: VTP Claims

 +2       ;;QUIT

ERR       ;File add messed up!!

 +1       ;

CLEAN1    ;Cleanse (FILE 442) fiscal signed receipts transmitted, but not filed correctly.

 +1        NEW PRCIEN,PRCPART,PRCRECPT,PRCTOT

 +2        KILL ^XTMP("PRCF223P")

 +3        SET ^XTMP("PRCF223P",0)=$$FMADD^XLFDT(DT,90)_"^"_DT

 +4        SET ^XTMP("PRCF223P",$JOB,0)="0"

 +5        SET (PRCIEN,PRCTOT)=0

A          SET PRCIEN=$ORDER(^PRC(442,PRCIEN))

           SET PRCPART=0

           IF 'PRCIEN

               GOTO ZZ

A1         SET PRCPART=$ORDER(^PRC(442,PRCIEN,11,PRCPART))

           IF 'PRCPART

               GOTO A

 +1        SET PRCRECPT=$GET(^PRC(442,PRCIEN,11,PRCPART,0))

           if PRCRECPT=""

               QUIT 

 +2        IF $PIECE(PRCRECPT,U,19)'["RR"

               GOTO A1

 +3        IF $PIECE(PRCRECPT,U,6)'=""

               GOTO A1

 +4        SET ^XTMP("PRCF223P",$JOB,1,PRCIEN,11,PRCPART,0)=PRCRECPT

           SET PRCTOT=PRCTOT+1

 +5        SET $PIECE(^PRC(442,PRCIEN,11,PRCPART,0),U,6)="Y"

 +6       ;W !!,PRCIEN,?12,$P(^PRC(442,PRCIEN,0),U),!,PRCRECPT

 +7        GOTO A1

ZZ         SET ^XTMP("PRCF223P",$JOB,1,0)=PRCTOT

 +1        DO MES^XPDUTL("")

           DO BMES^XPDUTL("**Cleansing of Receiving Report completed: "_PRCTOT_" RESETS **")

 +2        QUIT 

SETAO     ;Set 'AO' index for invalid sets in file 410, field 4 from routine PRCSEB

 +1        NEW PRCSIEN,PRCTOT

B          SET (PRCSIEN,PRCTOT)=0

B1         SET PRCSIEN=$ORDER(^PRCS(410,PRCSIEN))

           if 'PRCSIEN

               GOTO BQ

 +1        SET PRCSIP=$PIECE($GET(^PRCS(410,PRCSIEN,0)),U,6)

           if 'PRCSIP

               GOTO B1

 +2        IF $DATA(^PRCS(410,"AO",PRCSIP,PRCSIEN))

               GOTO B1

 +3        SET ^PRCS(410,"AO",PRCSIP,PRCSIEN)=""

           SET ^XTMP("PRCF223P",$JOB,2,PRCSIEN,0)=PRCSIP

 +4       ;W !,PRCSIEN,?15,PRCSIP

 +5        SET PRCTOT=PRCTOT+1

 +6        GOTO B1

BQ         SET ^XTMP("PRCF223P",$JOB,2,0)=PRCTOT

 +1        DO MES^XPDUTL("")

           DO BMES^XPDUTL("** File 410, 'AO' index reset completed: "_PRCTOT_" RESETS **")

 +2        QUIT