PRCFFUD1 ;WISC/SJG-UTILITY FOR CARRY FORWARD ;3/27/96 15:14
;;5.1;IFCAP;**58**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
QUIT
; This utility will determine the date that is to be used for the
; obligation processing date for Supply Fund transactions
;
EN() ;
N OPENQTR,PRIMARY,PODATE
S RETDATE=""
S OPENQTR=$$NP^PRC0B("^PRC(420,"_+PRC("SITE")_",",0,9)
S PRIMARY=$$NP^PRC0B("^PRC(442,"_+PO_",",0,12)
S PODATE=$$NP^PRC0B("^PRC(442,"_+PO_",",1,15)
REQ ; 2237 Request on Purchase Order
I $G(PRIMARY)]"" D G QUIT
.S RETDATE=$G(OPENQTR)
.I $G(PODATE)>$G(OPENQTR) S RETDATE=PODATE
.I $G(PODATE)<$G(OPENQTR) D NOW^%DTC S RETDATE=X
.Q
NOREQ ; No 2237 Request on Purchase Order
I $G(PRIMARY)="" D G QUIT
.I $G(PODATE)<$G(OPENQTR) D NOW^%DTC S RETDATE=X Q
.S RETDATE=PODATE
.Q
QUIT I RETDATE="" D NOW^%DTC S RETDATE=X
QUIT RETDATE
;
;A = RI OF 442 or 443.6, B = node 0 of file 442 or 443.6, C=file # 442 or 443.6,D=amend ri
DT442(A,B,C,D) ; set up prcfa(bbfy),prc(site),prc(fy),prc(qtr),prc(cp),prcfa(request),prc(rbdt),prc(bbfy),prc(podt),prc(amendt)
N PRCA,Z
S PRCA=$S($G(C)="":442,1:$G(C))
I $G(D) S PRC("AMENDT")=$P($G(^PRC(PRCA,A,6,D,0)),U,2)
S:$G(B)="" B=^PRC(PRCA,A,0)
S PRCFA("REQUEST")=$P(B,U,12),PRC("RBDT")=""
I PRCA=442 D GENDIQ^PRCFFU7(442,A,".1;.07;.03;17","IEN","")
I PRCFA("REQUEST") S Z=$G(^PRCS(410,PRCFA("REQUEST"),0)),PRC("RBDT")=$P(Z,U,11),PRCFA("BBFY")=$P(^(3),U,11),PRC("SITE")=$P(Z,"-"),PRC("FY")=$P(Z,"-",2),PRC("QTR")=$P(Z,"-",3),PRC("CP")=$P(Z,"-",4) I 1
S Z=$G(^PRC(PRCA,A,1)),PRC("PODT")=$P(Z,U,15) E S PRCFA("BBFY")=$P(^(23),U,2),PRC("SITE")=$P(B,"-"),PRC("CP")=$P(B,U,3),Z=$$DATE^PRC0C($P(Z,U,15),"I"),PRC("FY")=$E(Z,3,4),PRC("QTR")=$P(Z,U,2)
S PRCFA("BBFY")=+$$DATE^PRC0C(PRCFA("BBFY"),"I"),PRC("BBFY")=PRCFA("BBFY")
S PRC("FYQDT")=$P($$QTRDATE^PRC0D(PRC("FY"),PRC("QTR")),"^",7)
I 'PRC("RBDT") S PRC("RBDT")=$$RBDT^PRC0G(PRC("SITE")_U_PRC("FY")_U_PRC("QTR")_U_+PRC("CP")_U_PRCFA("BBFY"))
QUIT
;
;a = running balance date (fileman), b = p.o date or amend date
DTOBL(A,B) ;ef = default obligation date
QUIT $S(A<DT:DT,1:B)
;
OBLDAT(A,B) ; a new subroutine added as part of PRC*5.1*58.
; This new subroutine will enable the software to look for
; amendment funds in the correct fiscal quarter. The NOIS
; addressed by this code is LAH-0602-61845.
;
S RBDT=A,AMENDT=B
I AMENDT]"",PRC("FY")=$E(DT,2,3) S OBLDAT=AMENDT
E S OBLDAT=RBDT
K RBDT,AMENDT
Q OBLDAT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFFUD1 2530 printed Nov 22, 2024@17:14:10 Page 2
PRCFFUD1 ;WISC/SJG-UTILITY FOR CARRY FORWARD ;3/27/96 15:14
+1 ;;5.1;IFCAP;**58**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 QUIT
+5 ; This utility will determine the date that is to be used for the
+6 ; obligation processing date for Supply Fund transactions
+7 ;
EN() ;
+1 NEW OPENQTR,PRIMARY,PODATE
+2 SET RETDATE=""
+3 SET OPENQTR=$$NP^PRC0B("^PRC(420,"_+PRC("SITE")_",",0,9)
+4 SET PRIMARY=$$NP^PRC0B("^PRC(442,"_+PO_",",0,12)
+5 SET PODATE=$$NP^PRC0B("^PRC(442,"_+PO_",",1,15)
REQ ; 2237 Request on Purchase Order
+1 IF $GET(PRIMARY)]""
Begin DoDot:1
+2 SET RETDATE=$GET(OPENQTR)
+3 IF $GET(PODATE)>$GET(OPENQTR)
SET RETDATE=PODATE
+4 IF $GET(PODATE)<$GET(OPENQTR)
DO NOW^%DTC
SET RETDATE=X
+5 QUIT
End DoDot:1
GOTO QUIT
NOREQ ; No 2237 Request on Purchase Order
+1 IF $GET(PRIMARY)=""
Begin DoDot:1
+2 IF $GET(PODATE)<$GET(OPENQTR)
DO NOW^%DTC
SET RETDATE=X
QUIT
+3 SET RETDATE=PODATE
+4 QUIT
End DoDot:1
GOTO QUIT
QUIT IF RETDATE=""
DO NOW^%DTC
SET RETDATE=X
+1 QUIT RETDATE
+2 ;
+3 ;A = RI OF 442 or 443.6, B = node 0 of file 442 or 443.6, C=file # 442 or 443.6,D=amend ri
DT442(A,B,C,D) ; set up prcfa(bbfy),prc(site),prc(fy),prc(qtr),prc(cp),prcfa(request),prc(rbdt),prc(bbfy),prc(podt),prc(amendt)
+1 NEW PRCA,Z
+2 SET PRCA=$SELECT($GET(C)="":442,1:$GET(C))
+3 IF $GET(D)
SET PRC("AMENDT")=$PIECE($GET(^PRC(PRCA,A,6,D,0)),U,2)
+4 if $GET(B)=""
SET B=^PRC(PRCA,A,0)
+5 SET PRCFA("REQUEST")=$PIECE(B,U,12)
SET PRC("RBDT")=""
+6 IF PRCA=442
DO GENDIQ^PRCFFU7(442,A,".1;.07;.03;17","IEN","")
+7 IF PRCFA("REQUEST")
SET Z=$GET(^PRCS(410,PRCFA("REQUEST"),0))
SET PRC("RBDT")=$PIECE(Z,U,11)
SET PRCFA("BBFY")=$PIECE(^(3),U,11)
SET PRC("SITE")=$PIECE(Z,"-")
SET PRC("FY")=$PIECE(Z,"-",2)
SET PRC("QTR")=$PIECE(Z,"-",3)
SET PRC("CP")=$PIECE(Z,"-",4)
IF 1
+8 SET Z=$GET(^PRC(PRCA,A,1))
SET PRC("PODT")=$PIECE(Z,U,15)
IF '$TEST
SET PRCFA("BBFY")=$PIECE(^(23),U,2)
SET PRC("SITE")=$PIECE(B,"-")
SET PRC("CP")=$PIECE(B,U,3)
SET Z=$$DATE^PRC0C($PIECE(Z,U,15),"I")
SET PRC("FY")=$EXTRACT(Z,3,4)
SET PRC("QTR")=$PIECE(Z,U,2)
+9 SET PRCFA("BBFY")=+$$DATE^PRC0C(PRCFA("BBFY"),"I")
SET PRC("BBFY")=PRCFA("BBFY")
+10 SET PRC("FYQDT")=$PIECE($$QTRDATE^PRC0D(PRC("FY"),PRC("QTR")),"^",7)
+11 IF 'PRC("RBDT")
SET PRC("RBDT")=$$RBDT^PRC0G(PRC("SITE")_U_PRC("FY")_U_PRC("QTR")_U_+PRC("CP")_U_PRCFA("BBFY"))
+12 QUIT
+13 ;
+14 ;a = running balance date (fileman), b = p.o date or amend date
DTOBL(A,B) ;ef = default obligation date
+1 QUIT $SELECT(A<DT:DT,1:B)
+2 ;
OBLDAT(A,B) ; a new subroutine added as part of PRC*5.1*58.
+1 ; This new subroutine will enable the software to look for
+2 ; amendment funds in the correct fiscal quarter. The NOIS
+3 ; addressed by this code is LAH-0602-61845.
+4 ;
+5 SET RBDT=A
SET AMENDT=B
+6 IF AMENDT]""
IF PRC("FY")=$EXTRACT(DT,2,3)
SET OBLDAT=AMENDT
+7 IF '$TEST
SET OBLDAT=RBDT
+8 KILL RBDT,AMENDT
+9 QUIT OBLDAT
