source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSREC.m@ 623

Last change on this file since 623 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.8 KB
Line 
1PRCSREC ;WISC/KMB/DL-FMS 820 RECONCILIATION INTERCEPT ;12/28/99 11:06
2V ;;5.1;IFCAP;**96**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ; add entry to file 417, update CP balance on File 420
5 ; finally, send 820 to designee at CP
6 ; if duplicate, or CP is not in IFCAP, set status to "N" or "D"
7START ;
8 Q:'$D(PRCDA)
9 N AA,STATUS,STATION,CHECK,FILE,FCP,PODA,OUT,RDA,FY,QTR,TEMP,PONUM,PONUM1,TRANSNUM,X,Y,TDATE
10 N LINE,LNN,TRANCODE,COUNTER,AMT,RDATE,FMSREF,K,ERROR,STRING
11 N ENDFY,BEGFY
12 S OUT=0,(FCP,STATION)=""
13 D NOW^%DTC S RDATE=%,RDA=PRCDA
14 ; 1,2 is this the right type of transaction
15 S CHECK=$P($G(^PRCF(423.6,RDA,1,10000,0)),"^",3) I CHECK'["IFC" S OUT=1 D EVAL Q
16 S CHECK=$P($G(^PRCF(423.6,RDA,1,10000,0)),"^",5) I CHECK'["REC" S OUT=2 D EVAL Q
17 ; 3 is site correct
18 S STATION=$P($G(^PRCF(423.6,RDA,1,10000,0)),"^",4) I STATION="" S OUT=3 D EVAL Q
19 I '$D(^PRC(420,STATION)) S OUT=3 D EVAL Q
20 S LINE=10000 F S LINE=$O(^PRCF(423.6,RDA,1,LINE)) Q:'LINE D PROCESS
21 D KILL^PRCOSRV3(PRCDA)
22 QUIT
23PROCESS ; check each transmission line sent
24 Q:$P($G(^PRCF(423.6,RDA,1,LINE,0)),"^")["{"
25 S STRING=^PRCF(423.6,RDA,1,LINE,0)
26 ; 5,7 can a unique transmission record be determined
27 S (PONUM,PONUM1)=$P(STRING,"^",18) I PONUM="" S OUT=5 D EVAL Q
28 S LNN=$P(STRING,"^",19),TDATE=$P(STRING,"^",22) I TDATE="" S OUT=5 D EVAL Q
29 S TRANCODE=$P(STRING,"^",17) I TRANCODE="" S OUT=7 D EVAL Q
30 ; 8 is there a fiscal year/quarter
31 S STATION=$P(STRING,"^",8),FY=$P(STRING,"^",4),QUARTER=$P(STRING,"^",5),AMT=$P(STRING,"^",20)
32 I (FY="")!(QUARTER="") S OUT=8 D EVAL Q
33 I (QUARTER'?1N)!(QUARTER>5) S OUT=8 D EVAL Q
34 S ENDFY=$P(STRING,"^",3),BEGFY=$P(STRING,"^",2)
35 S TRANSNUM=TRANCODE_"-"_PONUM_"-"_TDATE_"-"_+LNN_"-"_QUARTER
36FCPCHEC ;
37 ; if there is a PO number, get CP from 442 record
38 S $P(STRING,"^",9)=$P(STRING,"^",21)
39 S PODA=0,(FCP,FILE)="" S PONUM=$E(PONUM,4,9),PONUM=STATION_"-"_PONUM
40 ; if it is not an employee payroll transaction ok to search file 442
41 I TRANCODE'="PR" D I $D(^PRC(420,STATION,1,+FCP,4,FY)) D CONTINU Q
42 .S:$D(^PRC(442,"B",PONUM)) PODA=$O(^PRC(442,"B",PONUM,0))
43 .I +PODA'=0 S FCP=$P($G(^PRC(442,PODA,0)),"^",3),FCP=+$P(FCP," ")
44 .Q
45 ; if no PO match is found, use required fields table
46 S ARRAY("BFY")=+$$YEAR^PRC0C($P(STRING,"^",2))
47 S FILE=417.1
48 S ARRAY("FUND")=$P(STRING,"^",6),ARRAY("AO")=$P(STRING,"^",7),ARRAY("FCPRJ")=$P(STRING,"^",10)
49 S ARRAY("PGM")=$P(STRING,"^",21),ARRAY("OC")=$P(STRING,"^",16),ARRAY("JOB")=$P(STRING,"^",14),ARRAY("SITE")=STATION
50 ;
51 S A="" D FINDCP I A="" S FCP="000" S STATUS="N" D SET Q
52 ;
53 S B=$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_A_""",",0)
54 I 'B S FCP="000" S STATUS="N" D SET Q
55 S FCP=+$P(^PRCD(420.141,B,0),"^",2)
56 I +FCP=0 S FCP="000" S STATUS="N" D SET Q
57 I '$D(^PRC(420,STATION,1,+FCP)) S FCP="000",STATUS="N" D SET Q
58CONTINU ; set control point balance on file 420
59 S FILE=417,TRANSNUM=TRANSNUM_"-"_FCP
60 S CHECK=TRANSNUM I $D(^PRCS(417,"B",CHECK)) S FILE=417.1 D SET Q
61 S STATUS="P" D SET S AA=STATION_"^"_+FCP_"^"_FY_"^"_QUARTER_"^"_AMT
62 I TRANCODE'="CC",$E(PONUM1,4,7)'?4A D EBAL^PRCSEZ(AA,"C")
63 D EBAL^PRCSEZ(AA,"O")
64 S INFORM=$P($T(MESSAGE+9),";;",2)
65 I STATUS="P" D ^PRCSREC1 K INFORM QUIT
66EVAL I OUT'=0 S ERROR=$P($T(MESSAGE+OUT),";;",2) D ^PRCSREC1
67 S OUT=0 K ERROR QUIT
68SET ; set data on file 417 with status of "P" (posted), "D" (duplicate), "N" (no CP)
69 S X=TRANSNUM,DIC="^PRCS("_FILE_",",DIC(0)="LZ",DLAYGO=FILE D FILE^DICN Q:Y=-1 S FMSDA=+Y K DLAYGO
70 L +^PRCS(FILE,FMSDA):5 Q:'$T F K=2,3,5:1:20 S $P(^PRCS(FILE,FMSDA,0),"^",K)=$P(STRING,"^",K)
71 S K=$P(STRING,"^",4),DIE=DIC,DA=FMSDA,DR="3////^S X=K" D ^DIE
72 S X=TDATE,X=$E(X,3,4)_"/"_$E(X,5,6)_"/"_$E(X,1,2) K %DT D ^%DT
73 S $P(^PRCS(FILE,FMSDA,0),"^",22)=Y
74 I FILE=417 S DIE=DIC,DA=FMSDA,DR="51///^S X=STATUS"_";"_"22///^S X=1" D ^DIE
75 S COUNTER=STATION_"-"_FY_"-"_QUARTER_"-"_FCP,$P(^PRCS(FILE,FMSDA,0),"^",21)=COUNTER
76 S ^PRCS(FILE,"C",COUNTER,FMSDA)=""
77 L -^PRCS(FILE,FMSDA)
78 K ARRAY,DA,DIC,DIE,DR QUIT
79FINDCP ;
80 S FUNDCODE=+$$FUND^PRC0C(ARRAY("FUND"),ARRAY("BFY")) Q:FUNDCODE=0
81 D DOCREQ^PRC0C(FUNDCODE,"AB","AB"),DOCREQ^PRC0C(FUNDCODE,"SAB","SAB")
82 F A="SPE","REV","GL" I $$REQ^PRC0C(FUNDCODE,A,"JOB")="Y" S SAB("JOB")="Y"
83 S EE="~",A=ARRAY("SITE")_EE_ARRAY("BFY")_EE_ARRAY("FUND")
84 F I="AO","PGM","FCPRJ","OC","JOB" D
85 .I $G(AB(I))="Y"!($G(SAB(I))="Y") S PIECE=ARRAY(I)
86 .E S PIECE=""
87 .S A=A_EE_PIECE
88 K AB,EE,I,PIECE,FIELD,FUNDCODE,SAB Q
89MESSAGE ;
90 ;;IFCAP transmission code is incorrect
91 ;;Transmission type is not correct for 820 processing
92 ;;Site reference is incorrect
93 ;;
94 ;;No FMS message transmission number sent in this transaction
95 ;;Duplicate message transmission number sent in transaction
96 ;;No FMS transaction code was sent for this transaction
97 ;;Invalid fiscal year or quarter sent in this transaction
98 ;;Your control point balances have been adjusted by the amount above
Note: See TracBrowser for help on using the repository browser.