| 1 | PRCFFUC ;WISC/SJG-UTILITY ROUTINE FOR HOLD FUNCTIONALITY ;7/24/00 23:13
|
|---|
| 2 | V ;;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
|
|---|
| 7 | CURRENT ; 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
|
|---|
| 13 | ACCPD ; 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
|
|---|
| 39 | CHECK ; Edit checking accounting period, obligation processing date, etc.
|
|---|
| 40 | D CHK1^PRCFFUC2 ;,CHK2^PRCFFUC2
|
|---|
| 41 | Q
|
|---|
| 42 | NACCPD ; 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
|
|---|
| 54 | N1 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
|
|---|
| 60 | SETUP ; 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
|
|---|
| 67 | CHGOBL ; 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
|
|---|
| 77 | CHG1 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
|
|---|
| 82 | ACCPDMO(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)
|
|---|
| 85 | MONTH(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
|
|---|
| 88 | TRANS(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)
|
|---|
| 90 | PARTS(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
|
|---|
| 97 | M1 W ! D EN^DDIOL("No change made to Obligation Processing Date.") Q
|
|---|
| 98 | M2 S EXIT1=1 W ! D EN^DDIOL("No change made to Accounting Period.") Q
|
|---|
| 99 | K1 K DTOUT,DIRUT,DUOUT Q
|
|---|
