PRCFFUC ;WISC/SJG-UTILITY ROUTINE FOR HOLD FUNCTIONALITY ;7/24/00 23:13
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
; This routine handles Hold Functionality processing
QUIT
CURRENT ; Determine current and user-entered accounting periods
N DATE
S PARTDT=PRCFA("OBLDATE") D PARTS(PARTDT,.DATE) S (PRCFA("ACCPDCK"),PRCFA("ACCPD"))=DATE
S DEFDT=DATEZ D PARTS(DEFDT,.DATE) S PRCFA("CURRENT")=DATE
D NOW^%DTC S CURDT=$$DATE^PRC0C(X,"I"),PARTDT=$$DATE^PRC0C(PARTDT,"I"),DEFDT=$$DATE^PRC0C(DEFDT,"I")
Q
ACCPD ; Prompt for default accounting period
N CHKDT,RESP,S1,S2,S3 D K1
S S1=$P(CURDT,U,8),S2=$P(PARTDT,U,8),S3=$S(S1>S2:CURDT,1:PARTDT)
S YY=$$TRANS(S3),RESP="YES",DIR(0)="Y"
S DIR("A",1)="This FMS document will be transmitted on "_YY_" and will"
S DIR("A",2)="affect the accounting period of "_$P(PRCFA("ACCPD"),U,2)_". The Accounting"
S DIR("A",3)="Period affected in FMS will be "_$P(PRCFA("ACCPD"),U)_"."
S DIR("A",4)=" "
I $D(PRCFA("MOD")),$P(PRCFA("MOD"),U)="E" S CHKDT=CURDT
I $D(PRCFA("MOD")),$P(PRCFA("MOD"),U)="M" S CHKDT=DEFDT
S S1=$E(PRCFA("OBLDATE"),1,5)_"00",S2=$E($P(CHKDT,U,7),1,5)_"00"
I S1<S2 D
.N STAR S $P(STAR,"*",80)="",RESP="NO",DIR("A",4.9)=STAR
.S DIR("A",5)="WARNING: The Obligation Processing Date entered is not in the"
.S DIR("A",6)="current accounting period! Sending this document to FMS with this date may"
.S DIR("A",7)="cause the document to reject with a Closed Accounting Period error!"
.S DIR("A",7.1)=STAR,DIR("A",7.2)=" "
.Q
S DIR("A")="Is this OK"
S DIR("?")="Enter '^' to exit this option."
S DIR("?",1)="Enter 'YES' or 'Y' or 'RETURN' to continue processing."
S DIR("?",2)="Enter 'NO' or 'N' to change the accounting period."
S DIR("B")=RESP W ! D ^DIR K DIR,S1,S2 W !
I $D(DIRUT) S EXIT=1 Q
I 'Y S EXIT1=0 D CHGOBL D:'EXIT1 NACCPD,CHECK G ACCPD
Q
CHECK ; Edit checking accounting period, obligation processing date, etc.
D CHK1^PRCFFUC2 ;,CHK2^PRCFFUC2
Q
NACCPD ; Prompt for new accounting period
S HELP=0 D SETUP,K1
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"
S DIR("A")="that this document should affect"
S DIR("A",1)="Enter the calendar month for the accounting period in the year"
S DIR("B")=$P($P(PRCFA("ACCPD"),U,2)," ")
S DIR("?")="^D H1^PRCFFUC1",DIR("??")="^D H2^PRCFFUC1"
D ^DIR K DIR
I $D(DTOUT)!($D(DUOUT)) S EXIT=1 Q
I HELP G NACCPD
S URESP=Y S URESPX=Y(0) S:URESPX'[" " URESPX=URESPX_$J(" ",URESPX-$L(URESPX))
S $P(URESP,U,2)=URESPX K Y,URESPX
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
S NFYR=$E(Y,1,3),NFYR=NFYR+1700,$P(URESP,U,3)=NFYR
S $P(PRCFA("ACCPD"),U,2)=$P(URESP,U,2)_$P(URESP,U,3)
S X=$P(PRCFA("ACCPD"),U,2) D ^%DT S $P(PRCFA("ACCPD"),U,3)=Y
N AP S AP=$$ACCPDMO($P(PRCFA("ACCPD"),U,3)) S $P(PRCFA("ACCPD"),U)=AP
Q
SETUP ; Backs up one accounting period
N X,X1,X2,X3,Z
S X1=$P(PRCFA("ACCPD"),U,3),X3=+$E(X1,4,5)
S X2=$S(X3=3:28,X3=5!(X3=7)!(X3=10)!(X3=12):30,1:31),X2=-X2
D C^%DTC
S X=$E(X,1,5)_"00" D PARTS(X,.Z) S PRCFA("ACCPD")=Z
Q
CHGOBL ; Change Obligation Processing Date
N DIR,Y D K1
S DIR(0)="Y",DIR("B")="YES"
S DIR("A")="Do you wish to change the Obligation Processing Date"
D ^DIR K DIR I 'Y!($D(DIRUT)) D M1 G CHG1
S Y=PRCFA("OBLDATE")
D D^PRCFQ S %DT="AEX",%DT("A")="Select Obligation Processing Date: ",%DT("B")=Y
W ! D ^%DT K %DT I Y<0 D M1
S (APCKDT,PRCFA("OBLDATE"))=Y,PARTDT=$$DATE^PRC0C(PRCFA("OBLDATE"),"I")
D PARTS(APCKDT,.DATE) S PRCFA("ACCPDCK")=DATE
CHG1 W ! S DIR(0)="Y",DIR("B")="YES"
S DIR("A")="Do you wish to change the Accounting Period"
D ^DIR K DIR I 'Y!($D(DIRUT)) D M2 Q
W ! D EN^DDIOL("Now enter the appropriate accounting Period.")
Q
ACCPDMO(A) ; Determine accounting period (calendar -> fiscal)
N DATE S DATE=$$DATE^PRC0C(A,"I")
Q $P(DATE,U,9)_$E($P(DATE,U),3,4)
MONTH(X,Y) ; Determine external form of month
S Y=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,+X)
Q Y
TRANS(X) ; Returns date in xx/xx/xx format
Q $P(X,U,4)_"/"_$P(X,U,5)_"/"_$E($P(X,U,3),3,4)
PARTS(AA,BB) ; Breaks out date into components
N DATE,CYR,FYR,MO,EXTMO
S DATE=$$DATE^PRC0C(AA,"I")
S FYR=$P(DATE,U),CYR=$P(DATE,U,3),MO=$P(DATE,U,4),EXTMO=$$MONTH(MO,"")
S $P(BB,U)=$P(DATE,U,9)_$E(FYR,3,4),$P(BB,U,2)=EXTMO_" "_CYR
S X=$P(BB,U,2) D ^%DT S $P(BB,U,3)=Y
Q
M1 W ! D EN^DDIOL("No change made to Obligation Processing Date.") Q
M2 S EXIT1=1 W ! D EN^DDIOL("No change made to Accounting Period.") Q
K1 K DTOUT,DIRUT,DUOUT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFFUC 4776 printed Nov 22, 2024@17:14:06 Page 2
PRCFFUC ;WISC/SJG-UTILITY ROUTINE FOR HOLD FUNCTIONALITY ;7/24/00 23:13
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
+3 ; This routine handles Hold Functionality processing
+4 QUIT
CURRENT ; Determine current and user-entered accounting periods
+1 NEW DATE
+2 SET PARTDT=PRCFA("OBLDATE")
DO PARTS(PARTDT,.DATE)
SET (PRCFA("ACCPDCK"),PRCFA("ACCPD"))=DATE
+3 SET DEFDT=DATEZ
DO PARTS(DEFDT,.DATE)
SET PRCFA("CURRENT")=DATE
+4 DO NOW^%DTC
SET CURDT=$$DATE^PRC0C(X,"I")
SET PARTDT=$$DATE^PRC0C(PARTDT,"I")
SET DEFDT=$$DATE^PRC0C(DEFDT,"I")
+5 QUIT
ACCPD ; Prompt for default accounting period
+1 NEW CHKDT,RESP,S1,S2,S3
DO K1
+2 SET S1=$PIECE(CURDT,U,8)
SET S2=$PIECE(PARTDT,U,8)
SET S3=$SELECT(S1>S2:CURDT,1:PARTDT)
+3 SET YY=$$TRANS(S3)
SET RESP="YES"
SET DIR(0)="Y"
+4 SET DIR("A",1)="This FMS document will be transmitted on "_YY_" and will"
+5 SET DIR("A",2)="affect the accounting period of "_$PIECE(PRCFA("ACCPD"),U,2)_". The Accounting"
+6 SET DIR("A",3)="Period affected in FMS will be "_$PIECE(PRCFA("ACCPD"),U)_"."
+7 SET DIR("A",4)=" "
+8 IF $DATA(PRCFA("MOD"))
IF $PIECE(PRCFA("MOD"),U)="E"
SET CHKDT=CURDT
+9 IF $DATA(PRCFA("MOD"))
IF $PIECE(PRCFA("MOD"),U)="M"
SET CHKDT=DEFDT
+10 SET S1=$EXTRACT(PRCFA("OBLDATE"),1,5)_"00"
SET S2=$EXTRACT($PIECE(CHKDT,U,7),1,5)_"00"
+11 IF S1<S2
Begin DoDot:1
+12 NEW STAR
SET $PIECE(STAR,"*",80)=""
SET RESP="NO"
SET DIR("A",4.9)=STAR
+13 SET DIR("A",5)="WARNING: The Obligation Processing Date entered is not in the"
+14 SET DIR("A",6)="current accounting period! Sending this document to FMS with this date may"
+15 SET DIR("A",7)="cause the document to reject with a Closed Accounting Period error!"
+16 SET DIR("A",7.1)=STAR
SET DIR("A",7.2)=" "
+17 QUIT
End DoDot:1
+18 SET DIR("A")="Is this OK"
+19 SET DIR("?")="Enter '^' to exit this option."
+20 SET DIR("?",1)="Enter 'YES' or 'Y' or 'RETURN' to continue processing."
+21 SET DIR("?",2)="Enter 'NO' or 'N' to change the accounting period."
+22 SET DIR("B")=RESP
WRITE !
DO ^DIR
KILL DIR,S1,S2
WRITE !
+23 IF $DATA(DIRUT)
SET EXIT=1
QUIT
+24 IF 'Y
SET EXIT1=0
DO CHGOBL
if 'EXIT1
DO NACCPD
DO CHECK
GOTO ACCPD
+25 QUIT
CHECK ; Edit checking accounting period, obligation processing date, etc.
+1 ;,CHK2^PRCFFUC2
DO CHK1^PRCFFUC2
+2 QUIT
NACCPD ; Prompt for new accounting period
+1 SET HELP=0
DO SETUP
DO K1
+2 WRITE !
SET 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"
+3 SET DIR("A")="that this document should affect"
+4 SET DIR("A",1)="Enter the calendar month for the accounting period in the year"
+5 SET DIR("B")=$PIECE($PIECE(PRCFA("ACCPD"),U,2)," ")
+6 SET DIR("?")="^D H1^PRCFFUC1"
SET DIR("??")="^D H2^PRCFFUC1"
+7 DO ^DIR
KILL DIR
+8 IF $DATA(DTOUT)!($DATA(DUOUT))
SET EXIT=1
QUIT
+9 IF HELP
GOTO NACCPD
+10 SET URESP=Y
SET URESPX=Y(0)
if URESPX'[" "
SET URESPX=URESPX_$JUSTIFY(" ",URESPX-$LENGTH(URESPX))
+11 SET $PIECE(URESP,U,2)=URESPX
KILL Y,URESPX
N1 WRITE !
SET %DT="A"
SET %DT("A")="Enter the calendar year for this accounting month: "
DO ^%DT
KILL %DT
IF Y<0
WRITE !
DO EN^DDIOL("Exit by '^' is not allowed.")
GOTO N1
+1 SET NFYR=$EXTRACT(Y,1,3)
SET NFYR=NFYR+1700
SET $PIECE(URESP,U,3)=NFYR
+2 SET $PIECE(PRCFA("ACCPD"),U,2)=$PIECE(URESP,U,2)_$PIECE(URESP,U,3)
+3 SET X=$PIECE(PRCFA("ACCPD"),U,2)
DO ^%DT
SET $PIECE(PRCFA("ACCPD"),U,3)=Y
+4 NEW AP
SET AP=$$ACCPDMO($PIECE(PRCFA("ACCPD"),U,3))
SET $PIECE(PRCFA("ACCPD"),U)=AP
+5 QUIT
SETUP ; Backs up one accounting period
+1 NEW X,X1,X2,X3,Z
+2 SET X1=$PIECE(PRCFA("ACCPD"),U,3)
SET X3=+$EXTRACT(X1,4,5)
+3 SET X2=$SELECT(X3=3:28,X3=5!(X3=7)!(X3=10)!(X3=12):30,1:31)
SET X2=-X2
+4 DO C^%DTC
+5 SET X=$EXTRACT(X,1,5)_"00"
DO PARTS(X,.Z)
SET PRCFA("ACCPD")=Z
+6 QUIT
CHGOBL ; Change Obligation Processing Date
+1 NEW DIR,Y
DO K1
+2 SET DIR(0)="Y"
SET DIR("B")="YES"
+3 SET DIR("A")="Do you wish to change the Obligation Processing Date"
+4 DO ^DIR
KILL DIR
IF 'Y!($DATA(DIRUT))
DO M1
GOTO CHG1
+5 SET Y=PRCFA("OBLDATE")
+6 DO D^PRCFQ
SET %DT="AEX"
SET %DT("A")="Select Obligation Processing Date: "
SET %DT("B")=Y
+7 WRITE !
DO ^%DT
KILL %DT
IF Y<0
DO M1
+8 SET (APCKDT,PRCFA("OBLDATE"))=Y
SET PARTDT=$$DATE^PRC0C(PRCFA("OBLDATE"),"I")
+9 DO PARTS(APCKDT,.DATE)
SET PRCFA("ACCPDCK")=DATE
CHG1 WRITE !
SET DIR(0)="Y"
SET DIR("B")="YES"
+1 SET DIR("A")="Do you wish to change the Accounting Period"
+2 DO ^DIR
KILL DIR
IF 'Y!($DATA(DIRUT))
DO M2
QUIT
+3 WRITE !
DO EN^DDIOL("Now enter the appropriate accounting Period.")
+4 QUIT
ACCPDMO(A) ; Determine accounting period (calendar -> fiscal)
+1 NEW DATE
SET DATE=$$DATE^PRC0C(A,"I")
+2 QUIT $PIECE(DATE,U,9)_$EXTRACT($PIECE(DATE,U),3,4)
MONTH(X,Y) ; Determine external form of month
+1 SET Y=$PIECE("January^February^March^April^May^June^July^August^September^October^November^December",U,+X)
+2 QUIT Y
TRANS(X) ; Returns date in xx/xx/xx format
+1 QUIT $PIECE(X,U,4)_"/"_$PIECE(X,U,5)_"/"_$EXTRACT($PIECE(X,U,3),3,4)
PARTS(AA,BB) ; Breaks out date into components
+1 NEW DATE,CYR,FYR,MO,EXTMO
+2 SET DATE=$$DATE^PRC0C(AA,"I")
+3 SET FYR=$PIECE(DATE,U)
SET CYR=$PIECE(DATE,U,3)
SET MO=$PIECE(DATE,U,4)
SET EXTMO=$$MONTH(MO,"")
+4 SET $PIECE(BB,U)=$PIECE(DATE,U,9)_$EXTRACT(FYR,3,4)
SET $PIECE(BB,U,2)=EXTMO_" "_CYR
+5 SET X=$PIECE(BB,U,2)
DO ^%DT
SET $PIECE(BB,U,3)=Y
+6 QUIT
M1 WRITE !
DO EN^DDIOL("No change made to Obligation Processing Date.")
QUIT
M2 SET EXIT1=1
WRITE !
DO EN^DDIOL("No change made to Accounting Period.")
QUIT
K1 KILL DTOUT,DIRUT,DUOUT
QUIT
