PRCFFU16 ;WISC/SJG-PO OBLIGATION UTILITY ;8/18/94 17:03
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
EN(IEN) ; Called from PO obligation processing
; IEN - Internal entry number from 442
W !,"Editing Auto Accrual information...",!
D POVENO^PRCFFU15(IEN)
S (ACCEDIT,AUTOACC,EXIT)=0
N FILE S FILE=$$FILE
D GENDIQ^PRCFFU7(FILE,IEN,".1;29;30","IEN","")
I $G(PRCTMP(FILE,IEN,29,"E"))="" D PROMPT I 'Y!($D(DIRUT)) D:EXIT MSG5 Q
I $G(PRCTMP(FILE,IEN,29,"E"))'="" S OB=IEN D MSG1,PROMPT1 I Y!($D(DIRUT)) D:EXIT MSG5 Q
W ! D MSG3,MSG4
I EXIT D MSG5 Q
W ! D CHK
I (NEWDATE="")&(NEWACC="YES") D
.K MSG W !!
.S MSG(1)="This Purchase Order Obligation does not have an Ending Date, but the"
.S MSG(2)="Auto Accrual flag is set to 'YES'.",MSG(3)=" "
.S MSG(4)="The Auto Accrual flag will be corrected and set to 'NO'."
.D EN^DDIOL(.MSG) W ! K MSG D EDIT H 3
.Q
S DIE=442,DA=IEN,DR="29////^S X=NEWDATE;30////^S X=NEWACC"
I $P(PRCFA("MOD"),U)="M",'PRCFA("RETRAN") S DIE=443.6
D ^DIE K DIE,DR
D TAG33^PRCFFU9
KILL AUTOACC,NEWACC,NEWDATE,OLDACC,OLDDATE,CONTEND,CONTENDA,CONTENDE,CONTENDI
QUIT
;
EDIT S DIE=442,DA=IEN,DR="30///^S X=""N"""
I $P(PRCFA("MOD"),U)="M",'PRCFA("RETRAN") S DIE=443.6
D ^DIE K DIE,DR
Q
PROMPT ; Prompt user
D EN^DDIOL("This "_$$LABEL^PRCFFU15_" Obligation appears to be for services.")
S DIR(0)="Y",DIR("A")="Will this Purchase Order Obligation need to be accrued in FMS",DIR("B")="YES"
S DIR("?")=" '^' to exit this option."
S DIR("?",1)="Enter one of the following:"
S DIR("?",2)=" 'NO' or 'N' if no accrual is needed OR it is for one month."
S DIR("?",3)=" 'YES' or 'Y' if the Obligation covers more than one month AND accrual is",DIR("?",4)=" needed."
S DIR("?",5)=" 'RETURN' for YES."
S DIR("??")="^D MSG2^PRCFFU15"
D ^DIR K DIR W !
I 'Y!($D(DIRUT)) N YY S YY=Y D EDIT,TAG33^PRCFFU9,MSG5 S Y=YY Q
S NEWACC=Y(0)
Q
MSG1 ; Display current auto accrual information
D MSG1^PRCFFU15
Q
PROMPT1 ; Prompt for correct values
S DIR(0)="Y",DIR("A")="Are these Auto Accrual values correct",DIR("B")="YES",DIR("??")="^D MSG2^PRCFFU15"
W ! D ^DIR K DIR W !
I Y S EXIT=0,PRCFA("ACCEDIT")=1
Q
MSG3 ; Prompt for Ending Date
S NEWDATE=$G(PRCTMP(FILE,IEN,29,"I")),EXIT=0
S DIR(0)="D",DIR("A")="END DATE FOR P.O. SERVICE ORDER"
I $G(PRCTMP(FILE,IEN,29,"E"))]"" S DIR("B")=$G(PRCTMP(FILE,IEN,29,"E"))
I $G(PRCTMP(FILE,IEN,29,"E"))="" D
.I $D(CONTENDA)>9 D
..N END,CONT S END="",CONT=$O(CONTENDA(END))
..S CONTEND=$P(CONTENDA(CONT),U)
..I CONTEND]"" S DIR("B")=CONTEND
..Q
.I $D(CONTENDA)<9 D
..N COM S COM=$G(PRCTMP(FILE,IEN,.1,"I")),Y=$P($$EOM^PRCFFU16(COM),U,2)
..D DD^%DT S DIR("B")=Y
..Q
.Q
D ^DIR K DIR
I $D(DIRUT) S EXIT=1 Q
I Y S NEWDATE=Y
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
D CHK1(NEWDATE)
Q
MSG4 ; Prompt for Auto Accrual
Q:EXIT
S NEWACC=$G(PRCTMP(FILE,IEN,30,"I")),EXIT=0
S DIR(0)="Y",DIR("A")="AUTO ACCRUAL FLAG",DIR("B")="YES"
I $G(PRCTMP(FILE,IEN,30,"E"))="" D
.S X1=NEWDATE,X2=$G(PRCTMP(FILE,IEN,.1,"I")) D ^%DTC I X<31 S DIR("B")="NO"
I $G(PRCTMP(FILE,IEN,30,"E"))]"" S DIR("B")=$G(PRCTMP(FILE,IEN,30,"E"))
D ^DIR K DIR
I $D(DIRUT) S EXIT=1 Q
S NEWACC=$S($E(Y,1)="Y":1,$E(Y,1)="N":0,$G(DIRUT)=1:0,'Y:0,Y:1,1:1)
Q
MSG5 ; Exit message
D MSG5^PRCFFU15
Q
MSG6 ; Returning message
D EN^DDIOL("Returning to Obligation processing...")
Q
CHK ;
S OLDDATE=$G(PRCTMP(FILE,IEN,29,"I"))
S OLDACC=$G(PRCTMP(FILE,IEN,33,"I"))
I OLDDATE=NEWDATE&(OLDACC=NEWACC) Q
I OLDDATE'=NEWDATE S (PRCFA("ACCEDIT"),ACCEDIT)=1
I OLDACC'=NEWACC S (PRCFA("ACCEDIT"),ACCEDIT)=1
Q
FILE() ; Determine file for lookup
I $D(PRCFA("MOD")),$P(PRCFA("MOD"),U)="E" S FILE=442
I $D(PRCFA("MOD")),$P(PRCFA("MOD"),U)="M" D
.I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=0 S FILE=443.6
.I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=1 S FILE=442
.Q
Q FILE
EOM(DATE) ; Determine end-of-month default date
N YR,MON,EOM,LEAP,DEF
S YR=$E(DATE,1,3)+1700,MON=+$E(DATE,4,5)
S LEAP=$S(YR#400=0:1,YR#4=0&'(YR#100=0):1,1:0)
S EOM=$P("31~"_(28+LEAP)_"~31~30~31~30~31~31~30~31~30~31","~",MON)
S FMEOM=$E(DATE,1,5)_EOM,DEF=MON_"/"_EOM
Q DEF_U_FMEOM
CHK1(DATE) ;Check for Ending date crossover to next FY.
S X="0930"_PRC("FY") D ^%DT
S X2=Y ; end of fiscal year for PO
S X=DATE D ^%DT
S X1=Y D ^%DTC
I X>0 W ! D EN^DDIOL("NOTE: The Ending Date for P.O. Service Order exceeds the End of the Fiscal Year!")
W !
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFFU16 4670 printed Sep 23, 2025@19:39:44 Page 2
PRCFFU16 ;WISC/SJG-PO OBLIGATION UTILITY ;8/18/94 17:03
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
EN(IEN) ; Called from PO obligation processing
+1 ; IEN - Internal entry number from 442
+2 WRITE !,"Editing Auto Accrual information...",!
+3 DO POVENO^PRCFFU15(IEN)
+4 SET (ACCEDIT,AUTOACC,EXIT)=0
+5 NEW FILE
SET FILE=$$FILE
+6 DO GENDIQ^PRCFFU7(FILE,IEN,".1;29;30","IEN","")
+7 IF $GET(PRCTMP(FILE,IEN,29,"E"))=""
DO PROMPT
IF 'Y!($DATA(DIRUT))
if EXIT
DO MSG5
QUIT
+8 IF $GET(PRCTMP(FILE,IEN,29,"E"))'=""
SET OB=IEN
DO MSG1
DO PROMPT1
IF Y!($DATA(DIRUT))
if EXIT
DO MSG5
QUIT
+9 WRITE !
DO MSG3
DO MSG4
+10 IF EXIT
DO MSG5
QUIT
+11 WRITE !
DO CHK
+12 IF (NEWDATE="")&(NEWACC="YES")
Begin DoDot:1
+13 KILL MSG
WRITE !!
+14 SET MSG(1)="This Purchase Order Obligation does not have an Ending Date, but the"
+15 SET MSG(2)="Auto Accrual flag is set to 'YES'."
SET MSG(3)=" "
+16 SET MSG(4)="The Auto Accrual flag will be corrected and set to 'NO'."
+17 DO EN^DDIOL(.MSG)
WRITE !
KILL MSG
DO EDIT
HANG 3
+18 QUIT
End DoDot:1
+19 SET DIE=442
SET DA=IEN
SET DR="29////^S X=NEWDATE;30////^S X=NEWACC"
+20 IF $PIECE(PRCFA("MOD"),U)="M"
IF 'PRCFA("RETRAN")
SET DIE=443.6
+21 DO ^DIE
KILL DIE,DR
+22 DO TAG33^PRCFFU9
+23 KILL AUTOACC,NEWACC,NEWDATE,OLDACC,OLDDATE,CONTEND,CONTENDA,CONTENDE,CONTENDI
+24 QUIT
+25 ;
EDIT SET DIE=442
SET DA=IEN
SET DR="30///^S X=""N"""
+1 IF $PIECE(PRCFA("MOD"),U)="M"
IF 'PRCFA("RETRAN")
SET DIE=443.6
+2 DO ^DIE
KILL DIE,DR
+3 QUIT
PROMPT ; Prompt user
+1 DO EN^DDIOL("This "_$$LABEL^PRCFFU15_" Obligation appears to be for services.")
+2 SET DIR(0)="Y"
SET DIR("A")="Will this Purchase Order Obligation need to be accrued in FMS"
SET DIR("B")="YES"
+3 SET DIR("?")=" '^' to exit this option."
+4 SET DIR("?",1)="Enter one of the following:"
+5 SET DIR("?",2)=" 'NO' or 'N' if no accrual is needed OR it is for one month."
+6 SET DIR("?",3)=" 'YES' or 'Y' if the Obligation covers more than one month AND accrual is"
SET DIR("?",4)=" needed."
+7 SET DIR("?",5)=" 'RETURN' for YES."
+8 SET DIR("??")="^D MSG2^PRCFFU15"
+9 DO ^DIR
KILL DIR
WRITE !
+10 IF 'Y!($DATA(DIRUT))
NEW YY
SET YY=Y
DO EDIT
DO TAG33^PRCFFU9
DO MSG5
SET Y=YY
QUIT
+11 SET NEWACC=Y(0)
+12 QUIT
MSG1 ; Display current auto accrual information
+1 DO MSG1^PRCFFU15
+2 QUIT
PROMPT1 ; Prompt for correct values
+1 SET DIR(0)="Y"
SET DIR("A")="Are these Auto Accrual values correct"
SET DIR("B")="YES"
SET DIR("??")="^D MSG2^PRCFFU15"
+2 WRITE !
DO ^DIR
KILL DIR
WRITE !
+3 IF Y
SET EXIT=0
SET PRCFA("ACCEDIT")=1
+4 QUIT
MSG3 ; Prompt for Ending Date
+1 SET NEWDATE=$GET(PRCTMP(FILE,IEN,29,"I"))
SET EXIT=0
+2 SET DIR(0)="D"
SET DIR("A")="END DATE FOR P.O. SERVICE ORDER"
+3 IF $GET(PRCTMP(FILE,IEN,29,"E"))]""
SET DIR("B")=$GET(PRCTMP(FILE,IEN,29,"E"))
+4 IF $GET(PRCTMP(FILE,IEN,29,"E"))=""
Begin DoDot:1
+5 IF $DATA(CONTENDA)>9
Begin DoDot:2
+6 NEW END,CONT
SET END=""
SET CONT=$ORDER(CONTENDA(END))
+7 SET CONTEND=$PIECE(CONTENDA(CONT),U)
+8 IF CONTEND]""
SET DIR("B")=CONTEND
+9 QUIT
End DoDot:2
+10 IF $DATA(CONTENDA)<9
Begin DoDot:2
+11 NEW COM
SET COM=$GET(PRCTMP(FILE,IEN,.1,"I"))
SET Y=$PIECE($$EOM^PRCFFU16(COM),U,2)
+12 DO DD^%DT
SET DIR("B")=Y
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 DO ^DIR
KILL DIR
+16 IF $DATA(DIRUT)
SET EXIT=1
QUIT
+17 IF Y
SET NEWDATE=Y
+18 SET X1=NEWDATE
SET X2=$GET(PRCTMP(FILE,IEN,.1,"I"))
DO ^%DTC
IF X<0
WRITE !
DO EN^DDIOL("The Ending Date cannot come before the Purchase Order Date - "_$GET(PRCTMP(FILE,IEN,.1,"E")))
WRITE !
GOTO MSG3
+19 DO CHK1(NEWDATE)
+20 QUIT
MSG4 ; Prompt for Auto Accrual
+1 if EXIT
QUIT
+2 SET NEWACC=$GET(PRCTMP(FILE,IEN,30,"I"))
SET EXIT=0
+3 SET DIR(0)="Y"
SET DIR("A")="AUTO ACCRUAL FLAG"
SET DIR("B")="YES"
+4 IF $GET(PRCTMP(FILE,IEN,30,"E"))=""
Begin DoDot:1
+5 SET X1=NEWDATE
SET X2=$GET(PRCTMP(FILE,IEN,.1,"I"))
DO ^%DTC
IF X<31
SET DIR("B")="NO"
End DoDot:1
+6 IF $GET(PRCTMP(FILE,IEN,30,"E"))]""
SET DIR("B")=$GET(PRCTMP(FILE,IEN,30,"E"))
+7 DO ^DIR
KILL DIR
+8 IF $DATA(DIRUT)
SET EXIT=1
QUIT
+9 SET NEWACC=$SELECT($EXTRACT(Y,1)="Y":1,$EXTRACT(Y,1)="N":0,$GET(DIRUT)=1:0,'Y:0,Y:1,1:1)
+10 QUIT
MSG5 ; Exit message
+1 DO MSG5^PRCFFU15
+2 QUIT
MSG6 ; Returning message
+1 DO EN^DDIOL("Returning to Obligation processing...")
+2 QUIT
CHK ;
+1 SET OLDDATE=$GET(PRCTMP(FILE,IEN,29,"I"))
+2 SET OLDACC=$GET(PRCTMP(FILE,IEN,33,"I"))
+3 IF OLDDATE=NEWDATE&(OLDACC=NEWACC)
QUIT
+4 IF OLDDATE'=NEWDATE
SET (PRCFA("ACCEDIT"),ACCEDIT)=1
+5 IF OLDACC'=NEWACC
SET (PRCFA("ACCEDIT"),ACCEDIT)=1
+6 QUIT
FILE() ; Determine file for lookup
+1 IF $DATA(PRCFA("MOD"))
IF $PIECE(PRCFA("MOD"),U)="E"
SET FILE=442
+2 IF $DATA(PRCFA("MOD"))
IF $PIECE(PRCFA("MOD"),U)="M"
Begin DoDot:1
+3 IF $DATA(PRCFA("RETRAN"))
IF PRCFA("RETRAN")=0
SET FILE=443.6
+4 IF $DATA(PRCFA("RETRAN"))
IF PRCFA("RETRAN")=1
SET FILE=442
+5 QUIT
End DoDot:1
+6 QUIT FILE
EOM(DATE) ; Determine end-of-month default date
+1 NEW YR,MON,EOM,LEAP,DEF
+2 SET YR=$EXTRACT(DATE,1,3)+1700
SET MON=+$EXTRACT(DATE,4,5)
+3 SET LEAP=$SELECT(YR#400=0:1,YR#4=0&'(YR#100=0):1,1:0)
+4 SET EOM=$PIECE("31~"_(28+LEAP)_"~31~30~31~30~31~31~30~31~30~31","~",MON)
+5 SET FMEOM=$EXTRACT(DATE,1,5)_EOM
SET DEF=MON_"/"_EOM
+6 QUIT DEF_U_FMEOM
CHK1(DATE) ;Check for Ending date crossover to next FY.
+1 SET X="0930"_PRC("FY")
DO ^%DT
+2 ; end of fiscal year for PO
SET X2=Y
+3 SET X=DATE
DO ^%DT
+4 SET X1=Y
DO ^%DTC
+5 IF X>0
WRITE !
DO EN^DDIOL("NOTE: The Ending Date for P.O. Service Order exceeds the End of the Fiscal Year!")
+6 WRITE !
+7 QUIT
