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