- 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 Feb 18, 2025@23:44:42 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