- 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 Feb 18, 2025@23:30:27 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
