PRCFFU5 ;WISC/SJG-OBLIGATION PROCESSING UTILITIES ;
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
QUIT
FMSFCP(REQST,SPFCP,MP) ;
; REQST - 2237 Request
; MP - Method of Processing
; SPFCP - Supply Fund Control Point
; FLAG - Flag to indicate if CP has been updated
; - Flag = "Y" when FCP has been updated
; - Flag = "N" when FCP has not been updated
;
N FLAG S FLAG="N"
; if supp fund, if meth of proc=cert, if 2237 req on PO, then flag="Y"
; if supp fund, if meth of proc=cert, if no 2237 req on PO, then flag ="N"
I SPFCP=2,MP=2 S FLAG=$S($G(REQST):"Y",1:"N")
;
; if supp fund, if meth of proc'=cert, if 2237 request on PO, then flag="N"
I SPFCP=2,MP'=2,$G(REQST) S FLAG="N"
;
; if not supp fund, if 2237 request on PO, then flag="Y"
; if not supp fund, if 2237 request not on PO, then flag="N"
I SPFCP'=2 S FLAG=$S($G(REQST):"Y",1:"N")
QUIT FLAG
;
ASKSITE(FLAG) ; Interface with GECS to prompt for station/fcp
N X,Y S ERROR=0
D ^PRCSUT
I '$D(PRC("SITE")) S ERROR=1 G EXIT
I '$D(PRC("CP")) S ERROR=1 G EXIT
S BUDSTR=$$ACC^PRC0C(PRC("SITE"),$P(PRC("CP")," ",1))
EXIT QUIT
;
NODE22 ; Called from PRCH58OB to build Node 22 for 1358 Obligations
K PRCTMP
N DA S DIC=442,DA=+PO,DIQ="PRCTMP(",DR="3;3.4;4;4.4;13;13.05" D EN^DIQ1 K DIC,DIQ,DR
K NODE S NODE=$G(^PRC(442,DA,22,0)) I NODE="" S ^PRC(442,DA,22,0)="^"_$P(^DD(442,41,0),U,2)
S STR="3;3.4^4;4.4^13.05;13"
F CTR=1:1:3 D
.K SUBSTR
.S SUBSTR=$P(STR,U,CTR)
.S BOC=+$G(PRCTMP(442,DA,$P(SUBSTR,";",1)))
.S AMT=$G(PRCTMP(442,DA,$P(SUBSTR,";",2)))
.I BOC D
..S DA(1)=DA
..S DIC="^PRC(442,"_DA(1)_",22,",DIC(0)="L",X=BOC
..K DD,DO D FILE^DICN
..N DA S FMSL=CTR,DIE=DIC,DA=+Y,DR="1////^S X=AMT;2////^S X=FMSL" D ^DIE
..K X,Y,DIE,DIC,DR
K PRCTMP,FMSL,NODE,STR,SUBSTR
QUIT
BBFY(PO) ; Get FMS Beginning Budget Fiscal Year
K PRCTEMP
N DA,BBFY S DIC=442,DA=+PO,DIQ="PRCTEMP(",DIQ(0)="IEN",DR=26
D EN^DIQ1 K DIC,DIQ,DR
S BBFY=$G(PRCTEMP(442,+PO,26,"E")),BBFY=$TR(BBFY," ")
K PRCTEMP
Q BBFY
;
DELSCH(XDATE) ; Get the Delivery Date from the latest of either the P.O.
; Delivery Date or the latest date in the Delivery Schedule
N LOOP,LOOP1,LOOP2
S DELSCH(9999999-DELDATE)="^^"_XDATE
I $D(^PRC(442.8,"AC",PRCFA("REF"))) D
.S LOOP=0 F S LOOP=$O(^PRC(442.8,"AC",PRCFA("REF"),LOOP)) Q:LOOP'>0 D
..S LOOP1=0 F S LOOP1=$O(^PRC(442.8,"AC",PRCFA("REF"),LOOP,LOOP1)) Q:LOOP1'>0 D
...S DELSCH("A",LOOP1)=^PRC(442.8,LOOP1,0)
...S YDATE=$P(DELSCH("A",LOOP1),U,3),DELSCH(9999999-YDATE)=DELSCH("A",LOOP1)
S LOOP2="" S DELSCHL=$O(DELSCH(LOOP2))
S XDATE=$P(DELSCH(DELSCHL),U,3)
K DELSCH,DELSCHL
Q XDATE
;
UPPER(X) ; Convert to 'UPPER' case
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;
LOWER(X) ; Convert to 'lower' case
Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFFU5 2944 printed Sep 23, 2025@19:39:54 Page 2
PRCFFU5 ;WISC/SJG-OBLIGATION PROCESSING UTILITIES ;
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 QUIT
FMSFCP(REQST,SPFCP,MP) ;
+1 ; REQST - 2237 Request
+2 ; MP - Method of Processing
+3 ; SPFCP - Supply Fund Control Point
+4 ; FLAG - Flag to indicate if CP has been updated
+5 ; - Flag = "Y" when FCP has been updated
+6 ; - Flag = "N" when FCP has not been updated
+7 ;
+8 NEW FLAG
SET FLAG="N"
+9 ; if supp fund, if meth of proc=cert, if 2237 req on PO, then flag="Y"
+10 ; if supp fund, if meth of proc=cert, if no 2237 req on PO, then flag ="N"
+11 IF SPFCP=2
IF MP=2
SET FLAG=$SELECT($GET(REQST):"Y",1:"N")
+12 ;
+13 ; if supp fund, if meth of proc'=cert, if 2237 request on PO, then flag="N"
+14 IF SPFCP=2
IF MP'=2
IF $GET(REQST)
SET FLAG="N"
+15 ;
+16 ; if not supp fund, if 2237 request on PO, then flag="Y"
+17 ; if not supp fund, if 2237 request not on PO, then flag="N"
+18 IF SPFCP'=2
SET FLAG=$SELECT($GET(REQST):"Y",1:"N")
+19 QUIT FLAG
+20 ;
ASKSITE(FLAG) ; Interface with GECS to prompt for station/fcp
+1 NEW X,Y
SET ERROR=0
+2 DO ^PRCSUT
+3 IF '$DATA(PRC("SITE"))
SET ERROR=1
GOTO EXIT
+4 IF '$DATA(PRC("CP"))
SET ERROR=1
GOTO EXIT
+5 SET BUDSTR=$$ACC^PRC0C(PRC("SITE"),$PIECE(PRC("CP")," ",1))
EXIT QUIT
+1 ;
NODE22 ; Called from PRCH58OB to build Node 22 for 1358 Obligations
+1 KILL PRCTMP
+2 NEW DA
SET DIC=442
SET DA=+PO
SET DIQ="PRCTMP("
SET DR="3;3.4;4;4.4;13;13.05"
DO EN^DIQ1
KILL DIC,DIQ,DR
+3 KILL NODE
SET NODE=$GET(^PRC(442,DA,22,0))
IF NODE=""
SET ^PRC(442,DA,22,0)="^"_$PIECE(^DD(442,41,0),U,2)
+4 SET STR="3;3.4^4;4.4^13.05;13"
+5 FOR CTR=1:1:3
Begin DoDot:1
+6 KILL SUBSTR
+7 SET SUBSTR=$PIECE(STR,U,CTR)
+8 SET BOC=+$GET(PRCTMP(442,DA,$PIECE(SUBSTR,";",1)))
+9 SET AMT=$GET(PRCTMP(442,DA,$PIECE(SUBSTR,";",2)))
+10 IF BOC
Begin DoDot:2
+11 SET DA(1)=DA
+12 SET DIC="^PRC(442,"_DA(1)_",22,"
SET DIC(0)="L"
SET X=BOC
+13 KILL DD,DO
DO FILE^DICN
+14 NEW DA
SET FMSL=CTR
SET DIE=DIC
SET DA=+Y
SET DR="1////^S X=AMT;2////^S X=FMSL"
DO ^DIE
+15 KILL X,Y,DIE,DIC,DR
End DoDot:2
End DoDot:1
+16 KILL PRCTMP,FMSL,NODE,STR,SUBSTR
+17 QUIT
BBFY(PO) ; Get FMS Beginning Budget Fiscal Year
+1 KILL PRCTEMP
+2 NEW DA,BBFY
SET DIC=442
SET DA=+PO
SET DIQ="PRCTEMP("
SET DIQ(0)="IEN"
SET DR=26
+3 DO EN^DIQ1
KILL DIC,DIQ,DR
+4 SET BBFY=$GET(PRCTEMP(442,+PO,26,"E"))
SET BBFY=$TRANSLATE(BBFY," ")
+5 KILL PRCTEMP
+6 QUIT BBFY
+7 ;
DELSCH(XDATE) ; Get the Delivery Date from the latest of either the P.O.
+1 ; Delivery Date or the latest date in the Delivery Schedule
+2 NEW LOOP,LOOP1,LOOP2
+3 SET DELSCH(9999999-DELDATE)="^^"_XDATE
+4 IF $DATA(^PRC(442.8,"AC",PRCFA("REF")))
Begin DoDot:1
+5 SET LOOP=0
FOR
SET LOOP=$ORDER(^PRC(442.8,"AC",PRCFA("REF"),LOOP))
if LOOP'>0
QUIT
Begin DoDot:2
+6 SET LOOP1=0
FOR
SET LOOP1=$ORDER(^PRC(442.8,"AC",PRCFA("REF"),LOOP,LOOP1))
if LOOP1'>0
QUIT
Begin DoDot:3
+7 SET DELSCH("A",LOOP1)=^PRC(442.8,LOOP1,0)
+8 SET YDATE=$PIECE(DELSCH("A",LOOP1),U,3)
SET DELSCH(9999999-YDATE)=DELSCH("A",LOOP1)
End DoDot:3
End DoDot:2
End DoDot:1
+9 SET LOOP2=""
SET DELSCHL=$ORDER(DELSCH(LOOP2))
+10 SET XDATE=$PIECE(DELSCH(DELSCHL),U,3)
+11 KILL DELSCH,DELSCHL
+12 QUIT XDATE
+13 ;
UPPER(X) ; Convert to 'UPPER' case
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 ;
LOWER(X) ; Convert to 'lower' case
+1 QUIT $TRANSLATE(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
