PRCFFU19 ;WISC/SJG-OBLIGATION PROCESSING UTILITIES ;1/12/95 5:33 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
QUIT
; .1 - P.O. Date
; .07 - Primary 2237
; .03 - Special FCP
; 17 - Validation Date for PA Esig
; PRCFA("BBFY") - BBFY as stored in file 442,field 26
; PRC("BBFY") - BBFY based on station #, doc FY, FCP
;
BBFYCHK(PO) ; Check BBFY at Obligation
N BBFY,BBFYCHK,FY2,FY4,FYI,N0,N1,PODT,PRIMREQ,REV,SFCP
I '$D(PRCFA("OBLDATE")) D NOW^%DTC S PRCFA("OBLDATE")=X K X
D GENDIQ^PRCFFU7(442,PO,".1;.07;.03;17","IEN","")
S N0=$$NODE^PRC0B("^PRC(442,"_PO_",",0)
S N1=$$NODE^PRC0B("^PRC(442,"_PO_",",1)
S PODT=$G(PRCTMP(442,PO,.1,"I"))
I PODT="" D DATE S PODT=$P(N1,U,15)
S PRIMREQ=$G(PRCTMP(442,PO,.07,"I"))
I PRIMREQ>0 D G T1
.S FYI=$$NP^PRC0B("^PRCS(410,"_PRIMREQ_",",3,11)
.I FYI]"" S (FY4,PRC("BBFY"))=$P($$DATE^PRC0C(FYI,"I"),U) Q
.I FYI="" D Q
..N TXN
..S TXN=$$NP^PRC0B("^PRCS(410,"_PRIMREQ_",",0,1)
..S FY2=$P(TXN,"-",2),(FY4,PRC("BBFY"))=$P($$YEAR^PRC0C(FY2),U)
..Q
S FY2=$E(PRCFA("OBLDATE"),2,3)+$E(PRCFA("OBLDATE"),4)
D GETBBFY S (FY4,PRC("BBFY"))=BBFY
T1 I PRC("BBFY")'=PRCFA("BBFY") D Q
.S BBFYCHK=$P($$DATE^PRC0C(PRCFA("OBLDATE"),"I"),U)
.S FY4=BBFYCHK D EDIT
QUIT
;
DATE ; Determine P.O. Date
K OK D DATE1 Q:$D(OK)
D ESIG
Q
DATE1 ; Get date of obligation from first node in Obligation Data
N OBND,OBDT
S OBND=$O(^PRC(442,PO,10,0)) I +OBND D Q:$D(OK)
.S OBDT=$P($G(^PRC(442,PO,10,OBND,0)),U,6) I $E(OBDT,1,7)?7N D SET(OBDT) Q
Q
ESIG ; Use Purchasing Agent Esig Date or Current Date
N CURDT,ESIGDT
S ESIGDT=$G(PRCTMP(442,PO,17,"I"))
I ESIGDT]"" S ESIGDT=$P(ESIGDT,".") I ESIGDT?7N D SET(ESIGDT) Q:$D(OK)
S CURDT=DT D SET(CURDT)
Q
SET(DATE) ; Set P.O. Date Field
N DIE,DR,DA
S DATE=$E(DATE,1,7),$P(N1,U,15)=DATE
S DIE="^PRC(442,",DR=".1////^S X=DATE",DA=PO D ^DIE S OK=1
Q
EDIT ; Edit BBFY field in File 442
N DIE,DR,DA,APPR
S APPR=$P($$ACC^PRC0C(PRC("SITE"),+PCP_U_PRC("FY")_U_PRC("BBFY")),U,11)
S DIE="^PRC(442,",DA=PO,DR="1.4///^S X=APPR;26///^S X=FY4" D ^DIE
S PRCFA("BBFY")=$$BBFY^PRCFFU5(PO)
Q
GETBBFY ; Get BBFY based on station, 2-digit FY, and FCP
S BBFY=$$BBFY^PRCSUT(+N0,FY2,+$P(N0,U,3))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFFU19 2296 printed Apr 09, 2024@21:10:13 Page 2
PRCFFU19 ;WISC/SJG-OBLIGATION PROCESSING UTILITIES ;1/12/95 5:33 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
+3 QUIT
+4 ; .1 - P.O. Date
+5 ; .07 - Primary 2237
+6 ; .03 - Special FCP
+7 ; 17 - Validation Date for PA Esig
+8 ; PRCFA("BBFY") - BBFY as stored in file 442,field 26
+9 ; PRC("BBFY") - BBFY based on station #, doc FY, FCP
+10 ;
BBFYCHK(PO) ; Check BBFY at Obligation
+1 NEW BBFY,BBFYCHK,FY2,FY4,FYI,N0,N1,PODT,PRIMREQ,REV,SFCP
+2 IF '$DATA(PRCFA("OBLDATE"))
DO NOW^%DTC
SET PRCFA("OBLDATE")=X
KILL X
+3 DO GENDIQ^PRCFFU7(442,PO,".1;.07;.03;17","IEN","")
+4 SET N0=$$NODE^PRC0B("^PRC(442,"_PO_",",0)
+5 SET N1=$$NODE^PRC0B("^PRC(442,"_PO_",",1)
+6 SET PODT=$GET(PRCTMP(442,PO,.1,"I"))
+7 IF PODT=""
DO DATE
SET PODT=$PIECE(N1,U,15)
+8 SET PRIMREQ=$GET(PRCTMP(442,PO,.07,"I"))
+9 IF PRIMREQ>0
Begin DoDot:1
+10 SET FYI=$$NP^PRC0B("^PRCS(410,"_PRIMREQ_",",3,11)
+11 IF FYI]""
SET (FY4,PRC("BBFY"))=$PIECE($$DATE^PRC0C(FYI,"I"),U)
QUIT
+12 IF FYI=""
Begin DoDot:2
+13 NEW TXN
+14 SET TXN=$$NP^PRC0B("^PRCS(410,"_PRIMREQ_",",0,1)
+15 SET FY2=$PIECE(TXN,"-",2)
SET (FY4,PRC("BBFY"))=$PIECE($$YEAR^PRC0C(FY2),U)
+16 QUIT
End DoDot:2
QUIT
End DoDot:1
GOTO T1
+17 SET FY2=$EXTRACT(PRCFA("OBLDATE"),2,3)+$EXTRACT(PRCFA("OBLDATE"),4)
+18 DO GETBBFY
SET (FY4,PRC("BBFY"))=BBFY
T1 IF PRC("BBFY")'=PRCFA("BBFY")
Begin DoDot:1
+1 SET BBFYCHK=$PIECE($$DATE^PRC0C(PRCFA("OBLDATE"),"I"),U)
+2 SET FY4=BBFYCHK
DO EDIT
End DoDot:1
QUIT
+3 QUIT
+4 ;
DATE ; Determine P.O. Date
+1 KILL OK
DO DATE1
if $DATA(OK)
QUIT
+2 DO ESIG
+3 QUIT
DATE1 ; Get date of obligation from first node in Obligation Data
+1 NEW OBND,OBDT
+2 SET OBND=$ORDER(^PRC(442,PO,10,0))
IF +OBND
Begin DoDot:1
+3 SET OBDT=$PIECE($GET(^PRC(442,PO,10,OBND,0)),U,6)
IF $EXTRACT(OBDT,1,7)?7N
DO SET(OBDT)
QUIT
End DoDot:1
if $DATA(OK)
QUIT
+4 QUIT
ESIG ; Use Purchasing Agent Esig Date or Current Date
+1 NEW CURDT,ESIGDT
+2 SET ESIGDT=$GET(PRCTMP(442,PO,17,"I"))
+3 IF ESIGDT]""
SET ESIGDT=$PIECE(ESIGDT,".")
IF ESIGDT?7N
DO SET(ESIGDT)
if $DATA(OK)
QUIT
+4 SET CURDT=DT
DO SET(CURDT)
+5 QUIT
SET(DATE) ; Set P.O. Date Field
+1 NEW DIE,DR,DA
+2 SET DATE=$EXTRACT(DATE,1,7)
SET $PIECE(N1,U,15)=DATE
+3 SET DIE="^PRC(442,"
SET DR=".1////^S X=DATE"
SET DA=PO
DO ^DIE
SET OK=1
+4 QUIT
EDIT ; Edit BBFY field in File 442
+1 NEW DIE,DR,DA,APPR
+2 SET APPR=$PIECE($$ACC^PRC0C(PRC("SITE"),+PCP_U_PRC("FY")_U_PRC("BBFY")),U,11)
+3 SET DIE="^PRC(442,"
SET DA=PO
SET DR="1.4///^S X=APPR;26///^S X=FY4"
DO ^DIE
+4 SET PRCFA("BBFY")=$$BBFY^PRCFFU5(PO)
+5 QUIT
GETBBFY ; Get BBFY based on station, 2-digit FY, and FCP
+1 SET BBFY=$$BBFY^PRCSUT(+N0,FY2,+$PIECE(N0,U,3))
+2 QUIT
