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 ---[H[J[2J[HPRCF223P 2635 printed Apr 09, 2024@21:00:43 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
