source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFFU6.m@ 1119

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

initial load of FOIAVistA 6/30/08 version

File size: 3.9 KB
Line 
1PRCFFU6 ;WISC/SJG-OBLIGATION PROCESSING UTILITIES ;4/27/94 2:46 PM
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ; No Top Level Entry
5 QUIT
6COMP(REC442,REC410,FLAG) ; Compare values from 1358 SOE and 1358 SOM
7 ; REC442 - IEN for original obligated 1358 from 442
8 ; REC410 - IEN for adjusted unobligated 1358 from 410
9 ; Get original values from 442
10 ; FLAG = Return value for error check^increase/decrease condition
11VAR ; Set up variables
12 K TMP442,TMP410 N LOOPX,CPFLAG,CCFLAG,BOCFLAG,ERFLAG,CHANGE
13 S (CPFLAG,CCFLAG,BOCFLAG,ERFLAG,CHANGE)=0
14 F LOOPX="BOC","DEL","DELSCH","FOB","PPT","VEND" S PRCFA(LOOPX)=""
15 F LOOPX="BOC","CC","FCP","VEND" S PRCFA("CHG",LOOPX)=""
16 N DA S DIC=442,DR="1;2;3;3.4;5",DA=+REC442,DIQ="TMP442(",DIQ(0)="IE" D EN^DIQ1 K DIC,DIQ,DR
17 N DA S DIC=410,DR="11;12;15;15.5;17;17.5",DA=+REC410,DIQ="TMP410(",DIQ(0)="IE" D EN^DIQ1 K DIC,DIQ,DR
18VEN ; Compare Vendor
19 ; Compare external vendor name on adjustment with external vendor name
20 ; from 442
21VEN1 I $G(TMP410(410,+REC410,12,"I"))'=$G(TMP442(442,+REC442,5,"I")) D G:PRCFA("VEND")=1 CP
22 .Q:$G(TMP442(442,+REC442,5,"I"))=""
23 .I $G(TMP410(410,+REC410,12,"I"))="" D
24 ..Q:$G(TMP410(410,+REC410,11,"E"))=$G(TMP442(442,+REC442,5,"E"))
25 ..K MSG W !
26 ..S MSG(1)=" The vendor on this 1358 adjustment is missing!",MSG(1.5)=" "
27 ..S MSG(2)=" Vendor on original 1358 obligation: "_$G(PRCTMP(410,$G(PRCTMP(442,+REC442,.07,"I")),11,"E"))
28 ..S MSG(3)=" Vendor pointer on original 1358 obligation: "_$G(PRCTMP(410,$G(PRCTMP(442,+REC442,.07,"I")),12,"I")),MSG(3.5)=" "
29 ..S MSG(4)=" Please have IRM correct the vendor on the 1358 adjustment before proceeding."
30 ..D EN^DDIOL(.MSG) K MSG
31 ..S PRCFA("VEND")=1,PRCFA("CHG","VEND")="VENDOR"
32 ..Q
33 .Q
34 ; Compare vendor pointer from adjustment with vendor pointer from 442
35VEN2 I $G(PRCTMP(410,$G(PRCTMP(442,+REC442,.07,"I")),12,"I"))'=$G(TMP410(410,+REC410,12,"I")) D
36 .I $G(TMP410(410,+REC410,12,"I"))="" Q:$G(PRCTMP(410,$G(PRCTMP(442,+REC442,.07,"I")),11,"E"))=$G(TMP410(410,+REC410,11,"E"))
37 .S PRCFA("VEND")=1,PRCFA("CHG","VEND")="VENDOR"
38 .K MSG W !
39 .S MSG(1)=" The vendor pointer on this 1358 adjustment is different from the vendor"
40 .S MSG(2)=" pointer on the 442 record!"
41 .S MSG(2.5)=" "
42 .S MSG(3)=" Vendor name on obligation: "_$G(PRCTMP(410,$G(PRCTMP(442,+REC442,.07,"I")),12,"E"))
43 .S MSG(4)=" Vendor pointer: "_$G(PRCTMP(410,$G(PRCTMP(442,+REC442,.07,"I")),12,"I"))
44 .S MSG(4.5)=" "
45 .S MSG(5)=" Vendor name on adjustment: "_$G(TMP410(410,+REC410,12,"E"))
46 .S MSG(6)=" Vendor pointer: "_$G(TMP410(410,+REC410,12,"I"))
47 .S MSG(6.5)=" "
48 .S MSG(7)=" Please contact IRM for assistance!"
49 .D EN^DDIOL(.MSG) K MSG
50 .Q
51CP ; Compare Control Point
52 I +$G(TMP410(410,+REC410,15,"I"))'=+$G(TMP442(442,+REC442,1,"I")) S CPFLAG=1,PRCFA("CHG","FCP")="FUND CONTROL POINT"
53CC ; Compare Cost Center
54 I +$G(TMP410(410,+REC410,15.5,"I"))'=+$G(TMP442(442,+REC442,2,"I")) S CCFLAG=1,PRCFA("CHG","CC")="COST CENTER"
55BOC ; Compare BOC
56 I +$G(TMP410(410,+REC410,17,"I"))'=+$G(TMP442(442,+REC442,3,"I")) S BOCFLAG=1,PRCFA("CHG","BOC")="BOC"
57AMT ; Check for change in amounts
58 I $G(TMP410(410,+REC410,17.5,"I")) D
59 .I TMP410(410,+REC410,17.5,"I")>0 S IDFLAG="I"
60 .I TMP410(410,+REC410,17.5,"I")<0 S IDFLAG="D"
61 D
62 .I BOCFLAG S (CHANGE,ERFLAG)=1 Q
63 .I PRCFA("VEND") S (CHANGE,ERFLAG)=1 Q
64 .I CPFLAG S (CHANGE,ERFLAG)=1 Q
65 .I CCFLAG S (CHANGE,ERFLAG)=1 Q
66 .Q
67 QUIT ERFLAG_"^"_IDFLAG_"^"_CHANGE
68UPDATE(REC442,REC410) ; Update Node 22 in File 442
69 S AMT=+$G(TMP410(410,+REC410,17.5,"I"))+$G(TMP442(442,+REC442,3.4,"I"))
70 S BOC=+$G(TMP442(442,+REC442,3,"I"))
71 N DA S DA(1)=REC442
72 S DIC="^PRC(442,"_DA(1)_",22,",DIC(0)="QEMZ",X=BOC D ^DIC
73 I Y>0 S DIE=DIC,DA=+Y,DR="1////^S X=AMT" D ^DIE
74 K DIC,DIE,DR,TMP410,TMP442,AMT,BOC
75 QUIT
76AUTACC ; Update Ending Date and Auto Accrual Flag
77 Q:'$D(TMP("NEWDATE"))
78 N DATE,FLAG
79 S DATE=$P(TMP("NEWDATE"),U),FLAG=$P(TMP("NEWACC"),U)
80 S DIE=442,DA=POIEN,DR="29///^S X=DATE;30///^S X=FLAG" D ^DIE K DIE,DR,TMP("NEWACC"),TMP("NEWDATE")
81 QUIT
Note: See TracBrowser for help on using the repository browser.