source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFFU16.m@ 1710

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

initial load of WorldVistAEHR

File size: 4.4 KB
RevLine 
[613]1PRCFFU16 ;WISC/SJG-PO OBLIGATION UTILITY ;8/18/94 17:03
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5EN(IEN) ; Called from PO obligation processing
6 ; IEN - Internal entry number from 442
7 W !,"Editing Auto Accrual information...",!
8 D POVENO^PRCFFU15(IEN)
9 S (ACCEDIT,AUTOACC,EXIT)=0
10 N FILE S FILE=$$FILE
11 D GENDIQ^PRCFFU7(FILE,IEN,".1;29;30","IEN","")
12 I $G(PRCTMP(FILE,IEN,29,"E"))="" D PROMPT I 'Y!($D(DIRUT)) D:EXIT MSG5 Q
13 I $G(PRCTMP(FILE,IEN,29,"E"))'="" S OB=IEN D MSG1,PROMPT1 I Y!($D(DIRUT)) D:EXIT MSG5 Q
14 W ! D MSG3,MSG4
15 I EXIT D MSG5 Q
16 W ! D CHK
17 I (NEWDATE="")&(NEWACC="YES") D
18 .K MSG W !!
19 .S MSG(1)="This Purchase Order Obligation does not have an Ending Date, but the"
20 .S MSG(2)="Auto Accrual flag is set to 'YES'.",MSG(3)=" "
21 .S MSG(4)="The Auto Accrual flag will be corrected and set to 'NO'."
22 .D EN^DDIOL(.MSG) W ! K MSG D EDIT H 3
23 .Q
24 S DIE=442,DA=IEN,DR="29////^S X=NEWDATE;30////^S X=NEWACC"
25 I $P(PRCFA("MOD"),U)="M",'PRCFA("RETRAN") S DIE=443.6
26 D ^DIE K DIE,DR
27 D TAG33^PRCFFU9
28 KILL AUTOACC,NEWACC,NEWDATE,OLDACC,OLDDATE,CONTEND,CONTENDA,CONTENDE,CONTENDI
29 QUIT
30 ;
31EDIT S DIE=442,DA=IEN,DR="30///^S X=""N"""
32 I $P(PRCFA("MOD"),U)="M",'PRCFA("RETRAN") S DIE=443.6
33 D ^DIE K DIE,DR
34 Q
35PROMPT ; Prompt user
36 D EN^DDIOL("This "_$$LABEL^PRCFFU15_" Obligation appears to be for services.")
37 S DIR(0)="Y",DIR("A")="Will this Purchase Order Obligation need to be accrued in FMS",DIR("B")="YES"
38 S DIR("?")=" '^' to exit this option."
39 S DIR("?",1)="Enter one of the following:"
40 S DIR("?",2)=" 'NO' or 'N' if no accrual is needed OR it is for one month."
41 S DIR("?",3)=" 'YES' or 'Y' if the Obligation covers more than one month AND accrual is",DIR("?",4)=" needed."
42 S DIR("?",5)=" 'RETURN' for YES."
43 S DIR("??")="^D MSG2^PRCFFU15"
44 D ^DIR K DIR W !
45 I 'Y!($D(DIRUT)) N YY S YY=Y D EDIT,TAG33^PRCFFU9,MSG5 S Y=YY Q
46 S NEWACC=Y(0)
47 Q
48MSG1 ; Display current auto accrual information
49 D MSG1^PRCFFU15
50 Q
51PROMPT1 ; Prompt for correct values
52 S DIR(0)="Y",DIR("A")="Are these Auto Accrual values correct",DIR("B")="YES",DIR("??")="^D MSG2^PRCFFU15"
53 W ! D ^DIR K DIR W !
54 I Y S EXIT=0,PRCFA("ACCEDIT")=1
55 Q
56MSG3 ; Prompt for Ending Date
57 S NEWDATE=$G(PRCTMP(FILE,IEN,29,"I")),EXIT=0
58 S DIR(0)="D",DIR("A")="END DATE FOR P.O. SERVICE ORDER"
59 I $G(PRCTMP(FILE,IEN,29,"E"))]"" S DIR("B")=$G(PRCTMP(FILE,IEN,29,"E"))
60 I $G(PRCTMP(FILE,IEN,29,"E"))="" D
61 .I $D(CONTENDA)>9 D
62 ..N END,CONT S END="",CONT=$O(CONTENDA(END))
63 ..S CONTEND=$P(CONTENDA(CONT),U)
64 ..I CONTEND]"" S DIR("B")=CONTEND
65 ..Q
66 .I $D(CONTENDA)<9 D
67 ..N COM S COM=$G(PRCTMP(FILE,IEN,.1,"I")),Y=$P($$EOM^PRCFFU16(COM),U,2)
68 ..D DD^%DT S DIR("B")=Y
69 ..Q
70 .Q
71 D ^DIR K DIR
72 I $D(DIRUT) S EXIT=1 Q
73 I Y S NEWDATE=Y
74 S X1=NEWDATE,X2=$G(PRCTMP(FILE,IEN,.1,"I")) D ^%DTC I X<0 W ! D EN^DDIOL("The Ending Date cannot come before the Purchase Order Date - "_$G(PRCTMP(FILE,IEN,.1,"E"))) W ! G MSG3
75 D CHK1(NEWDATE)
76 Q
77MSG4 ; Prompt for Auto Accrual
78 Q:EXIT
79 S NEWACC=$G(PRCTMP(FILE,IEN,30,"I")),EXIT=0
80 S DIR(0)="Y",DIR("A")="AUTO ACCRUAL FLAG",DIR("B")="YES"
81 I $G(PRCTMP(FILE,IEN,30,"E"))="" D
82 .S X1=NEWDATE,X2=$G(PRCTMP(FILE,IEN,.1,"I")) D ^%DTC I X<31 S DIR("B")="NO"
83 I $G(PRCTMP(FILE,IEN,30,"E"))]"" S DIR("B")=$G(PRCTMP(FILE,IEN,30,"E"))
84 D ^DIR K DIR
85 I $D(DIRUT) S EXIT=1 Q
86 S NEWACC=$S($E(Y,1)="Y":1,$E(Y,1)="N":0,$G(DIRUT)=1:0,'Y:0,Y:1,1:1)
87 Q
88MSG5 ; Exit message
89 D MSG5^PRCFFU15
90 Q
91MSG6 ; Returning message
92 D EN^DDIOL("Returning to Obligation processing...")
93 Q
94CHK ;
95 S OLDDATE=$G(PRCTMP(FILE,IEN,29,"I"))
96 S OLDACC=$G(PRCTMP(FILE,IEN,33,"I"))
97 I OLDDATE=NEWDATE&(OLDACC=NEWACC) Q
98 I OLDDATE'=NEWDATE S (PRCFA("ACCEDIT"),ACCEDIT)=1
99 I OLDACC'=NEWACC S (PRCFA("ACCEDIT"),ACCEDIT)=1
100 Q
101FILE() ; Determine file for lookup
102 I $D(PRCFA("MOD")),$P(PRCFA("MOD"),U)="E" S FILE=442
103 I $D(PRCFA("MOD")),$P(PRCFA("MOD"),U)="M" D
104 .I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=0 S FILE=443.6
105 .I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=1 S FILE=442
106 .Q
107 Q FILE
108EOM(DATE) ; Determine end-of-month default date
109 N YR,MON,EOM,LEAP,DEF
110 S YR=$E(DATE,1,3)+1700,MON=+$E(DATE,4,5)
111 S LEAP=$S(YR#400=0:1,YR#4=0&'(YR#100=0):1,1:0)
112 S EOM=$P("31~"_(28+LEAP)_"~31~30~31~30~31~31~30~31~30~31","~",MON)
113 S FMEOM=$E(DATE,1,5)_EOM,DEF=MON_"/"_EOM
114 Q DEF_U_FMEOM
115CHK1(DATE) ;Check for Ending date crossover to next FY.
116 S X="0930"_PRC("FY") D ^%DT
117 S X2=Y ; end of fiscal year for PO
118 S X=DATE D ^%DT
119 S X1=Y D ^%DTC
120 I X>0 W ! D EN^DDIOL("NOTE: The Ending Date for P.O. Service Order exceeds the End of the Fiscal Year!")
121 W !
122 Q
Note: See TracBrowser for help on using the repository browser.