source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFFUC.m@ 1154

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

initial load of WorldVistAEHR
File size: 4.6 KB
RevLine 
[613]1PRCFFUC ;WISC/SJG-UTILITY ROUTINE FOR HOLD FUNCTIONALITY ;7/24/00 23:13
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; This routine handles Hold Functionality processing
6 QUIT
7CURRENT ; Determine current and user-entered accounting periods
8 N DATE
9 S PARTDT=PRCFA("OBLDATE") D PARTS(PARTDT,.DATE) S (PRCFA("ACCPDCK"),PRCFA("ACCPD"))=DATE
10 S DEFDT=DATEZ D PARTS(DEFDT,.DATE) S PRCFA("CURRENT")=DATE
11 D NOW^%DTC S CURDT=$$DATE^PRC0C(X,"I"),PARTDT=$$DATE^PRC0C(PARTDT,"I"),DEFDT=$$DATE^PRC0C(DEFDT,"I")
12 Q
13ACCPD ; Prompt for default accounting period
14 N CHKDT,RESP,S1,S2,S3 D K1
15 S S1=$P(CURDT,U,8),S2=$P(PARTDT,U,8),S3=$S(S1>S2:CURDT,1:PARTDT)
16 S YY=$$TRANS(S3),RESP="YES",DIR(0)="Y"
17 S DIR("A",1)="This FMS document will be transmitted on "_YY_" and will"
18 S DIR("A",2)="affect the accounting period of "_$P(PRCFA("ACCPD"),U,2)_". The Accounting"
19 S DIR("A",3)="Period affected in FMS will be "_$P(PRCFA("ACCPD"),U)_"."
20 S DIR("A",4)=" "
21 I $D(PRCFA("MOD")),$P(PRCFA("MOD"),U)="E" S CHKDT=CURDT
22 I $D(PRCFA("MOD")),$P(PRCFA("MOD"),U)="M" S CHKDT=DEFDT
23 S S1=$E(PRCFA("OBLDATE"),1,5)_"00",S2=$E($P(CHKDT,U,7),1,5)_"00"
24 I S1<S2 D
25 .N STAR S $P(STAR,"*",80)="",RESP="NO",DIR("A",4.9)=STAR
26 .S DIR("A",5)="WARNING: The Obligation Processing Date entered is not in the"
27 .S DIR("A",6)="current accounting period! Sending this document to FMS with this date may"
28 .S DIR("A",7)="cause the document to reject with a Closed Accounting Period error!"
29 .S DIR("A",7.1)=STAR,DIR("A",7.2)=" "
30 .Q
31 S DIR("A")="Is this OK"
32 S DIR("?")="Enter '^' to exit this option."
33 S DIR("?",1)="Enter 'YES' or 'Y' or 'RETURN' to continue processing."
34 S DIR("?",2)="Enter 'NO' or 'N' to change the accounting period."
35 S DIR("B")=RESP W ! D ^DIR K DIR,S1,S2 W !
36 I $D(DIRUT) S EXIT=1 Q
37 I 'Y S EXIT1=0 D CHGOBL D:'EXIT1 NACCPD,CHECK G ACCPD
38 Q
39CHECK ; Edit checking accounting period, obligation processing date, etc.
40 D CHK1^PRCFFUC2 ;,CHK2^PRCFFUC2
41 Q
42NACCPD ; Prompt for new accounting period
43 S HELP=0 D SETUP,K1
44 W ! S DIR("0")="SOM^1:January;2:February;3:March;4:April;5:May;6:June;7:July;8:August;9:September;10:October;11:November;12:December"
45 S DIR("A")="that this document should affect"
46 S DIR("A",1)="Enter the calendar month for the accounting period in the year"
47 S DIR("B")=$P($P(PRCFA("ACCPD"),U,2)," ")
48 S DIR("?")="^D H1^PRCFFUC1",DIR("??")="^D H2^PRCFFUC1"
49 D ^DIR K DIR
50 I $D(DTOUT)!($D(DUOUT)) S EXIT=1 Q
51 I HELP G NACCPD
52 S URESP=Y S URESPX=Y(0) S:URESPX'[" " URESPX=URESPX_$J(" ",URESPX-$L(URESPX))
53 S $P(URESP,U,2)=URESPX K Y,URESPX
54N1 W ! S %DT="A",%DT("A")="Enter the calendar year for this accounting month: " D ^%DT K %DT I Y<0 W ! D EN^DDIOL("Exit by '^' is not allowed.") G N1
55 S NFYR=$E(Y,1,3),NFYR=NFYR+1700,$P(URESP,U,3)=NFYR
56 S $P(PRCFA("ACCPD"),U,2)=$P(URESP,U,2)_$P(URESP,U,3)
57 S X=$P(PRCFA("ACCPD"),U,2) D ^%DT S $P(PRCFA("ACCPD"),U,3)=Y
58 N AP S AP=$$ACCPDMO($P(PRCFA("ACCPD"),U,3)) S $P(PRCFA("ACCPD"),U)=AP
59 Q
60SETUP ; Backs up one accounting period
61 N X,X1,X2,X3,Z
62 S X1=$P(PRCFA("ACCPD"),U,3),X3=+$E(X1,4,5)
63 S X2=$S(X3=3:28,X3=5!(X3=7)!(X3=10)!(X3=12):30,1:31),X2=-X2
64 D C^%DTC
65 S X=$E(X,1,5)_"00" D PARTS(X,.Z) S PRCFA("ACCPD")=Z
66 Q
67CHGOBL ; Change Obligation Processing Date
68 N DIR,Y D K1
69 S DIR(0)="Y",DIR("B")="YES"
70 S DIR("A")="Do you wish to change the Obligation Processing Date"
71 D ^DIR K DIR I 'Y!($D(DIRUT)) D M1 G CHG1
72 S Y=PRCFA("OBLDATE")
73 D D^PRCFQ S %DT="AEX",%DT("A")="Select Obligation Processing Date: ",%DT("B")=Y
74 W ! D ^%DT K %DT I Y<0 D M1
75 S (APCKDT,PRCFA("OBLDATE"))=Y,PARTDT=$$DATE^PRC0C(PRCFA("OBLDATE"),"I")
76 D PARTS(APCKDT,.DATE) S PRCFA("ACCPDCK")=DATE
77CHG1 W ! S DIR(0)="Y",DIR("B")="YES"
78 S DIR("A")="Do you wish to change the Accounting Period"
79 D ^DIR K DIR I 'Y!($D(DIRUT)) D M2 Q
80 W ! D EN^DDIOL("Now enter the appropriate accounting Period.")
81 Q
82ACCPDMO(A) ; Determine accounting period (calendar -> fiscal)
83 N DATE S DATE=$$DATE^PRC0C(A,"I")
84 Q $P(DATE,U,9)_$E($P(DATE,U),3,4)
85MONTH(X,Y) ; Determine external form of month
86 S Y=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,+X)
87 Q Y
88TRANS(X) ; Returns date in xx/xx/xx format
89 Q $P(X,U,4)_"/"_$P(X,U,5)_"/"_$E($P(X,U,3),3,4)
90PARTS(AA,BB) ; Breaks out date into components
91 N DATE,CYR,FYR,MO,EXTMO
92 S DATE=$$DATE^PRC0C(AA,"I")
93 S FYR=$P(DATE,U),CYR=$P(DATE,U,3),MO=$P(DATE,U,4),EXTMO=$$MONTH(MO,"")
94 S $P(BB,U)=$P(DATE,U,9)_$E(FYR,3,4),$P(BB,U,2)=EXTMO_" "_CYR
95 S X=$P(BB,U,2) D ^%DT S $P(BB,U,3)=Y
96 Q
97M1 W ! D EN^DDIOL("No change made to Obligation Processing Date.") Q
98M2 S EXIT1=1 W ! D EN^DDIOL("No change made to Accounting Period.") Q
99K1 K DTOUT,DIRUT,DUOUT Q
Note: See TracBrowser for help on using the repository browser.