PRCSREC ;WISC/KMB/DL-FMS 820 RECONCILIATION INTERCEPT ;12/28/99 11:06
V ;;5.1;IFCAP;**96,192**;Oct 20, 2000;Build 3
;Per VA Directive 6402, this routine should not be modified.
; add entry to file 417, update CP balance on File 420
; finally, send 820 to designee at CP
; if duplicate, or CP is not in IFCAP, set status to "N" or "D"
;
;PRC*5.1*192 Modify FMS interface to insure that regular monies
; are not attached to an old PO number + extra digit
; to pull FCP for posting. If the PO number has
; length >9 ignore PO matching for FCP, defaulting to
; FCP using required fields table.
;
START ;
Q:'$D(PRCDA)
N AA,STATUS,STATION,CHECK,FILE,FCP,PODA,OUT,RDA,FY,QTR,TEMP,PONUM,PONUM1,TRANSNUM,X,Y,TDATE
N LINE,LNN,TRANCODE,COUNTER,AMT,RDATE,FMSREF,K,ERROR,STRING
N ENDFY,BEGFY
S OUT=0,(FCP,STATION)=""
D NOW^%DTC S RDATE=%,RDA=PRCDA
; 1,2 is this the right type of transaction
S CHECK=$P($G(^PRCF(423.6,RDA,1,10000,0)),"^",3) I CHECK'["IFC" S OUT=1 D EVAL Q
S CHECK=$P($G(^PRCF(423.6,RDA,1,10000,0)),"^",5) I CHECK'["REC" S OUT=2 D EVAL Q
; 3 is site correct
S STATION=$P($G(^PRCF(423.6,RDA,1,10000,0)),"^",4) I STATION="" S OUT=3 D EVAL Q
I '$D(^PRC(420,STATION)) S OUT=3 D EVAL Q
S LINE=10000 F S LINE=$O(^PRCF(423.6,RDA,1,LINE)) Q:'LINE D PROCESS
D KILL^PRCOSRV3(PRCDA)
QUIT
PROCESS ; check each transmission line sent
Q:$P($G(^PRCF(423.6,RDA,1,LINE,0)),"^")["{"
S STRING=^PRCF(423.6,RDA,1,LINE,0)
; 5,7 can a unique transmission record be determined
S (PONUM,PONUM1)=$P(STRING,"^",18) I PONUM="" S OUT=5 D EVAL Q
S LNN=$P(STRING,"^",19),TDATE=$P(STRING,"^",22) I TDATE="" S OUT=5 D EVAL Q
S TRANCODE=$P(STRING,"^",17) I TRANCODE="" S OUT=7 D EVAL Q
; 8 is there a fiscal year/quarter
S STATION=$P(STRING,"^",8),FY=$P(STRING,"^",4),QUARTER=$P(STRING,"^",5),AMT=$P(STRING,"^",20)
I (FY="")!(QUARTER="") S OUT=8 D EVAL Q
I (QUARTER'?1N)!(QUARTER>5) S OUT=8 D EVAL Q
S ENDFY=$P(STRING,"^",3),BEGFY=$P(STRING,"^",2)
S TRANSNUM=TRANCODE_"-"_PONUM_"-"_TDATE_"-"_+LNN_"-"_QUARTER
FCPCHEC ;
; if there is a PO number, get CP from 442 record
S $P(STRING,"^",9)=$P(STRING,"^",21)
S PODA=0,(FCP,FILE)="" S PONUM=$E(PONUM,4,9),PONUM=STATION_"-"_PONUM
; if it is not an employee payroll transaction ok to search file 442
I TRANCODE'="PR"&($L(PONUM1)<10) D I $D(^PRC(420,STATION,1,+FCP,4,FY)) D CONTINU Q
.S:$D(^PRC(442,"B",PONUM)) PODA=$O(^PRC(442,"B",PONUM,0))
.I +PODA'=0 S FCP=$P($G(^PRC(442,PODA,0)),"^",3),FCP=+$P(FCP," ")
.Q
; if no PO match is found, use required fields table
S ARRAY("BFY")=+$$YEAR^PRC0C($P(STRING,"^",2))
S FILE=417.1
S ARRAY("FUND")=$P(STRING,"^",6),ARRAY("AO")=$P(STRING,"^",7),ARRAY("FCPRJ")=$P(STRING,"^",10)
S ARRAY("PGM")=$P(STRING,"^",21),ARRAY("OC")=$P(STRING,"^",16),ARRAY("JOB")=$P(STRING,"^",14),ARRAY("SITE")=STATION
;
S A="" D FINDCP I A="" S FCP="000" S STATUS="N" D SET Q
;
S B=$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_A_""",",0)
I 'B S FCP="000" S STATUS="N" D SET Q
S FCP=+$P(^PRCD(420.141,B,0),"^",2)
I +FCP=0 S FCP="000" S STATUS="N" D SET Q
I '$D(^PRC(420,STATION,1,+FCP)) S FCP="000",STATUS="N" D SET Q
CONTINU ; set control point balance on file 420
S FILE=417,TRANSNUM=TRANSNUM_"-"_FCP
S CHECK=TRANSNUM I $D(^PRCS(417,"B",CHECK)) S FILE=417.1 D SET Q
S STATUS="P" D SET S AA=STATION_"^"_+FCP_"^"_FY_"^"_QUARTER_"^"_AMT
I TRANCODE'="CC",$E(PONUM1,4,7)'?4A D EBAL^PRCSEZ(AA,"C")
D EBAL^PRCSEZ(AA,"O")
S INFORM=$P($T(MESSAGE+9),";;",2)
I STATUS="P" D ^PRCSREC1 K INFORM QUIT
EVAL I OUT'=0 S ERROR=$P($T(MESSAGE+OUT),";;",2) D ^PRCSREC1
S OUT=0 K ERROR QUIT
SET ; set data on file 417 with status of "P" (posted), "D" (duplicate), "N" (no CP)
S X=TRANSNUM,DIC="^PRCS("_FILE_",",DIC(0)="LZ",DLAYGO=FILE D FILE^DICN Q:Y=-1 S FMSDA=+Y K DLAYGO
L +^PRCS(FILE,FMSDA):5 Q:'$T F K=2,3,5:1:20 S $P(^PRCS(FILE,FMSDA,0),"^",K)=$P(STRING,"^",K)
S K=$P(STRING,"^",4),DIE=DIC,DA=FMSDA,DR="3////^S X=K" D ^DIE
S X=TDATE,X=$E(X,3,4)_"/"_$E(X,5,6)_"/"_$E(X,1,2) K %DT D ^%DT
S $P(^PRCS(FILE,FMSDA,0),"^",22)=Y
I FILE=417 S DIE=DIC,DA=FMSDA,DR="51///^S X=STATUS"_";"_"22///^S X=1" D ^DIE
S COUNTER=STATION_"-"_FY_"-"_QUARTER_"-"_FCP,$P(^PRCS(FILE,FMSDA,0),"^",21)=COUNTER
S ^PRCS(FILE,"C",COUNTER,FMSDA)=""
L -^PRCS(FILE,FMSDA)
K ARRAY,DA,DIC,DIE,DR QUIT
FINDCP ;
S FUNDCODE=+$$FUND^PRC0C(ARRAY("FUND"),ARRAY("BFY")) Q:FUNDCODE=0
D DOCREQ^PRC0C(FUNDCODE,"AB","AB"),DOCREQ^PRC0C(FUNDCODE,"SAB","SAB")
F A="SPE","REV","GL" I $$REQ^PRC0C(FUNDCODE,A,"JOB")="Y" S SAB("JOB")="Y"
S EE="~",A=ARRAY("SITE")_EE_ARRAY("BFY")_EE_ARRAY("FUND")
F I="AO","PGM","FCPRJ","OC","JOB" D
.I $G(AB(I))="Y"!($G(SAB(I))="Y") S PIECE=ARRAY(I)
.E S PIECE=""
.S A=A_EE_PIECE
K AB,EE,I,PIECE,FIELD,FUNDCODE,SAB Q
MESSAGE ;
;;IFCAP transmission code is incorrect
;;Transmission type is not correct for 820 processing
;;Site reference is incorrect
;;
;;No FMS message transmission number sent in this transaction
;;Duplicate message transmission number sent in transaction
;;No FMS transaction code was sent for this transaction
;;Invalid fiscal year or quarter sent in this transaction
;;Your control point balances have been adjusted by the amount above
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSREC 5329 printed Apr 09, 2024@21:05:47 Page 2
PRCSREC ;WISC/KMB/DL-FMS 820 RECONCILIATION INTERCEPT ;12/28/99 11:06
V ;;5.1;IFCAP;**96,192**;Oct 20, 2000;Build 3
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ; add entry to file 417, update CP balance on File 420
+3 ; finally, send 820 to designee at CP
+4 ; if duplicate, or CP is not in IFCAP, set status to "N" or "D"
+5 ;
+6 ;PRC*5.1*192 Modify FMS interface to insure that regular monies
+7 ; are not attached to an old PO number + extra digit
+8 ; to pull FCP for posting. If the PO number has
+9 ; length >9 ignore PO matching for FCP, defaulting to
+10 ; FCP using required fields table.
+11 ;
START ;
+1 if '$DATA(PRCDA)
QUIT
+2 NEW AA,STATUS,STATION,CHECK,FILE,FCP,PODA,OUT,RDA,FY,QTR,TEMP,PONUM,PONUM1,TRANSNUM,X,Y,TDATE
+3 NEW LINE,LNN,TRANCODE,COUNTER,AMT,RDATE,FMSREF,K,ERROR,STRING
+4 NEW ENDFY,BEGFY
+5 SET OUT=0
SET (FCP,STATION)=""
+6 DO NOW^%DTC
SET RDATE=%
SET RDA=PRCDA
+7 ; 1,2 is this the right type of transaction
+8 SET CHECK=$PIECE($GET(^PRCF(423.6,RDA,1,10000,0)),"^",3)
IF CHECK'["IFC"
SET OUT=1
DO EVAL
QUIT
+9 SET CHECK=$PIECE($GET(^PRCF(423.6,RDA,1,10000,0)),"^",5)
IF CHECK'["REC"
SET OUT=2
DO EVAL
QUIT
+10 ; 3 is site correct
+11 SET STATION=$PIECE($GET(^PRCF(423.6,RDA,1,10000,0)),"^",4)
IF STATION=""
SET OUT=3
DO EVAL
QUIT
+12 IF '$DATA(^PRC(420,STATION))
SET OUT=3
DO EVAL
QUIT
+13 SET LINE=10000
FOR
SET LINE=$ORDER(^PRCF(423.6,RDA,1,LINE))
if 'LINE
QUIT
DO PROCESS
+14 DO KILL^PRCOSRV3(PRCDA)
+15 QUIT
PROCESS ; check each transmission line sent
+1 if $PIECE($GET(^PRCF(423.6,RDA,1,LINE,0)),"^")["{"
QUIT
+2 SET STRING=^PRCF(423.6,RDA,1,LINE,0)
+3 ; 5,7 can a unique transmission record be determined
+4 SET (PONUM,PONUM1)=$PIECE(STRING,"^",18)
IF PONUM=""
SET OUT=5
DO EVAL
QUIT
+5 SET LNN=$PIECE(STRING,"^",19)
SET TDATE=$PIECE(STRING,"^",22)
IF TDATE=""
SET OUT=5
DO EVAL
QUIT
+6 SET TRANCODE=$PIECE(STRING,"^",17)
IF TRANCODE=""
SET OUT=7
DO EVAL
QUIT
+7 ; 8 is there a fiscal year/quarter
+8 SET STATION=$PIECE(STRING,"^",8)
SET FY=$PIECE(STRING,"^",4)
SET QUARTER=$PIECE(STRING,"^",5)
SET AMT=$PIECE(STRING,"^",20)
+9 IF (FY="")!(QUARTER="")
SET OUT=8
DO EVAL
QUIT
+10 IF (QUARTER'?1N)!(QUARTER>5)
SET OUT=8
DO EVAL
QUIT
+11 SET ENDFY=$PIECE(STRING,"^",3)
SET BEGFY=$PIECE(STRING,"^",2)
+12 SET TRANSNUM=TRANCODE_"-"_PONUM_"-"_TDATE_"-"_+LNN_"-"_QUARTER
FCPCHEC ;
+1 ; if there is a PO number, get CP from 442 record
+2 SET $PIECE(STRING,"^",9)=$PIECE(STRING,"^",21)
+3 SET PODA=0
SET (FCP,FILE)=""
SET PONUM=$EXTRACT(PONUM,4,9)
SET PONUM=STATION_"-"_PONUM
+4 ; if it is not an employee payroll transaction ok to search file 442
+5 IF TRANCODE'="PR"&($LENGTH(PONUM1)<10)
Begin DoDot:1
+6 if $DATA(^PRC(442,"B",PONUM))
SET PODA=$ORDER(^PRC(442,"B",PONUM,0))
+7 IF +PODA'=0
SET FCP=$PIECE($GET(^PRC(442,PODA,0)),"^",3)
SET FCP=+$PIECE(FCP," ")
+8 QUIT
End DoDot:1
IF $DATA(^PRC(420,STATION,1,+FCP,4,FY))
DO CONTINU
QUIT
+9 ; if no PO match is found, use required fields table
+10 SET ARRAY("BFY")=+$$YEAR^PRC0C($PIECE(STRING,"^",2))
+11 SET FILE=417.1
+12 SET ARRAY("FUND")=$PIECE(STRING,"^",6)
SET ARRAY("AO")=$PIECE(STRING,"^",7)
SET ARRAY("FCPRJ")=$PIECE(STRING,"^",10)
+13 SET ARRAY("PGM")=$PIECE(STRING,"^",21)
SET ARRAY("OC")=$PIECE(STRING,"^",16)
SET ARRAY("JOB")=$PIECE(STRING,"^",14)
SET ARRAY("SITE")=STATION
+14 ;
+15 SET A=""
DO FINDCP
IF A=""
SET FCP="000"
SET STATUS="N"
DO SET
QUIT
+16 ;
+17 SET B=$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_A_""",",0)
+18 IF 'B
SET FCP="000"
SET STATUS="N"
DO SET
QUIT
+19 SET FCP=+$PIECE(^PRCD(420.141,B,0),"^",2)
+20 IF +FCP=0
SET FCP="000"
SET STATUS="N"
DO SET
QUIT
+21 IF '$DATA(^PRC(420,STATION,1,+FCP))
SET FCP="000"
SET STATUS="N"
DO SET
QUIT
CONTINU ; set control point balance on file 420
+1 SET FILE=417
SET TRANSNUM=TRANSNUM_"-"_FCP
+2 SET CHECK=TRANSNUM
IF $DATA(^PRCS(417,"B",CHECK))
SET FILE=417.1
DO SET
QUIT
+3 SET STATUS="P"
DO SET
SET AA=STATION_"^"_+FCP_"^"_FY_"^"_QUARTER_"^"_AMT
+4 IF TRANCODE'="CC"
IF $EXTRACT(PONUM1,4,7)'?4A
DO EBAL^PRCSEZ(AA,"C")
+5 DO EBAL^PRCSEZ(AA,"O")
+6 SET INFORM=$PIECE($TEXT(MESSAGE+9),";;",2)
+7 IF STATUS="P"
DO ^PRCSREC1
KILL INFORM
QUIT
EVAL IF OUT'=0
SET ERROR=$PIECE($TEXT(MESSAGE+OUT),";;",2)
DO ^PRCSREC1
+1 SET OUT=0
KILL ERROR
QUIT
SET ; set data on file 417 with status of "P" (posted), "D" (duplicate), "N" (no CP)
+1 SET X=TRANSNUM
SET DIC="^PRCS("_FILE_","
SET DIC(0)="LZ"
SET DLAYGO=FILE
DO FILE^DICN
if Y=-1
QUIT
SET FMSDA=+Y
KILL DLAYGO
+2 LOCK +^PRCS(FILE,FMSDA):5
if '$TEST
QUIT
FOR K=2,3,5:1:20
SET $PIECE(^PRCS(FILE,FMSDA,0),"^",K)=$PIECE(STRING,"^",K)
+3 SET K=$PIECE(STRING,"^",4)
SET DIE=DIC
SET DA=FMSDA
SET DR="3////^S X=K"
DO ^DIE
+4 SET X=TDATE
SET X=$EXTRACT(X,3,4)_"/"_$EXTRACT(X,5,6)_"/"_$EXTRACT(X,1,2)
KILL %DT
DO ^%DT
+5 SET $PIECE(^PRCS(FILE,FMSDA,0),"^",22)=Y
+6 IF FILE=417
SET DIE=DIC
SET DA=FMSDA
SET DR="51///^S X=STATUS"_";"_"22///^S X=1"
DO ^DIE
+7 SET COUNTER=STATION_"-"_FY_"-"_QUARTER_"-"_FCP
SET $PIECE(^PRCS(FILE,FMSDA,0),"^",21)=COUNTER
+8 SET ^PRCS(FILE,"C",COUNTER,FMSDA)=""
+9 LOCK -^PRCS(FILE,FMSDA)
+10 KILL ARRAY,DA,DIC,DIE,DR
QUIT
FINDCP ;
+1 SET FUNDCODE=+$$FUND^PRC0C(ARRAY("FUND"),ARRAY("BFY"))
if FUNDCODE=0
QUIT
+2 DO DOCREQ^PRC0C(FUNDCODE,"AB","AB")
DO DOCREQ^PRC0C(FUNDCODE,"SAB","SAB")
+3 FOR A="SPE","REV","GL"
IF $$REQ^PRC0C(FUNDCODE,A,"JOB")="Y"
SET SAB("JOB")="Y"
+4 SET EE="~"
SET A=ARRAY("SITE")_EE_ARRAY("BFY")_EE_ARRAY("FUND")
+5 FOR I="AO","PGM","FCPRJ","OC","JOB"
Begin DoDot:1
+6 IF $GET(AB(I))="Y"!($GET(SAB(I))="Y")
SET PIECE=ARRAY(I)
+7 IF '$TEST
SET PIECE=""
+8 SET A=A_EE_PIECE
End DoDot:1
+9 KILL AB,EE,I,PIECE,FIELD,FUNDCODE,SAB
QUIT
MESSAGE ;
+1 ;;IFCAP transmission code is incorrect
+2 ;;Transmission type is not correct for 820 processing
+3 ;;Site reference is incorrect
+4 ;;
+5 ;;No FMS message transmission number sent in this transaction
+6 ;;Duplicate message transmission number sent in transaction
+7 ;;No FMS transaction code was sent for this transaction
+8 ;;Invalid fiscal year or quarter sent in this transaction
+9 ;;Your control point balances have been adjusted by the amount above
