Routine: PRCFFU3

PRCFFU3 ;WISC/SJG-FMS LIN,MOA,MOB,MOZ SEGMENTS ;4/27/94  1:39 PM

V ;;5.1;IFCAP;**178**;Oct 20, 2000;Build 3

 ;Per VHA Directive 2004-038, this routine should not be modified.

LIN ;BUILD 'LIN' SEGMENT

 S TMPLINE=TMPLINE+1

 S ^TMP($J,"PRCMO",INT,TMPLINE)="LIN^~"

MOA ;BUILD 'MOA' SEGMENT

 N SEG,BOC,AMT,NUM

 I PRCFA("MP")=21 I (TRCODE="SO")&(TYCODE="M") S NUM=NUMB D  G MOASEG

 .N DA K PRCTMP S DIC=442,DR="3;7.2",DA=+PO,DIQ="PRCTMP("

 .D EN^DIQ1 K DIC,DIQ,DR

 .S BOC=+$G(PRCTMP(442,+PO,3))

 .S AMT=$J(+$G(PRCTMP(442,+PO,7.2)),0,2)

 .S NUM=$E("00"_NUM,$L(NUM),99)

 S AMT=$P(FMSNOD,U,2) I TYCODE="E" Q:AMT'>0

 S BOC=$P(FMSNOD,U),AMT=$J($P(FMSNOD,U,2),0,2),NUMB=$P(FMSNOD,U,3),NUM=$E("00"_NUMB,$L(NUMB),99)

 I TYCODE="E" I NUM=991 I (FOB="D")&(+AMT=0) Q

 I TYCODE="M",'$D(PRCFCHG("BOC",BOC,NUMB)) Q

 I TYCODE="M",$D(PRCFCHG("BOC",BOC,NUMB)) D

 .S AMT=$J($P(PRCFCHG("BOC",BOC,NUMB),U,2),0,2)

 .S IDFLAG=$P(PRCFCHG("BOC",BOC,NUMB),U,4)

MOASEG S TMPLINE=TMPLINE+1,SEG=""

 S SEG=NUM,$P(SEG,U,5)=PRCBUD,$P(SEG,U,13)=BOC

 I $D(PRCFMO("JOB")),PRCFMO("JOB")="Y" S $P(SEG,U,15)=$P(PRCSTR,U,10)

 I $D(PRCFMO("RC")),PRCFMO("RC")="Y" S $P(SEG,U,16)=""

 S $P(SEG,U,17)=AMT,$P(SEG,U,18)=IDFLAG

 S ^TMP($J,"PRCMO",INT,TMPLINE)="LIN^~MOA^"_SEG_"^~"

 QUIT

MOB ;BUILD 'MOB' SEGMENT

 N SEG

 S TMPLINE=TMPLINE+1,SEG=""

 S ^TMP($J,"PRCMO",INT,TMPLINE)="MOB^~"

 I SEG S ^TMP($J,"PRCMO",INT,TMPLINE)="MOB^"_SEG_"^~"

MOZ ;BUILD 'MOZ' SEGMENT

 N SEG

 S TMPLINE=TMPLINE+1,SEG=""

 S ^TMP($J,"PRCMO",INT,TMPLINE)="MOZ^~"

 I SEG S ^TMP($J,"PRCMO",INT,TMPLINE)="MOZ^"_SEG_"^~"

BUD(STR1) ;BUILD BUDGET STRING

 N BFY,EFY S STR2=""

 S BFY=$E($P(PRCSTR,U,6),3,4),EFY=$E($P(PRCSTR,U,7),3,4)

 S $P(STR2,U)=BFY

 I BFY=EFY S $P(STR2,U,2)=""

 I BFY'=EFY S $P(STR2,U,2)=EFY

 S STR2=STR2_"^"_$P(PRCSTR,U,5)

SITE I $D(PRCFMO("SITE")),PRCFMO("SITE")="Y" S $P(STR2,U,4)=PRC("SITE")

 I '$D(PRCFMO("SITE")) S $P(STR2,U,4)=""

 I $D(PRCFMO("SITE")),PRCFMO("SITE")="N" S $P(STR2,U,4)=""

 I $D(PRCFMO("SITE")),PRCFMO("SITE")="O" S $P(STR2,U,4)=PRC("SITE")

SAT K PRCTMP(442,+PO,31) D GENDIQ^PRCFFU7(442,+PO,31,"IEN","")

 S SATSTN=$G(PRCTMP(442,+PO,31,"E"))

 I SATSTN]"" S SATSTN=$E(SATSTN,4,5) I SATSTN="" S SATSTN="  "

 S $P(STR2,U,5)=SATSTN

 ;PRC*5.1*178 modifies Cost Center field to include entire 6 digit FCP Cost Center

CC I $D(PRCFMO("CC")),PRCFMO("CC")="Y" S PRCCCC=$E(PRCCC,1,6),PRCCCC=PRCCCC_$E("000000",1,6-$L(PRCCCC)),PRCCCC=PRCCCC_"^"

 I '$D(PRCFMO("CC")) S PRCCCC=""

 I $D(PRCFMO("CC")),PRCFMO("CC")="N" S PRCCCC=""

 I $D(PRCFMO("CC")),PRCFMO("CC")="O" S PRCCCC=$E(PRCCC,1,6),PRCCCC=PRCCCC_$E("000000",1,6-$L(PRCCCC)),PRCCCC=PRCCCC_"^"

 ;PRC*5.1*178 modifies Sub Cost Center field to '00'

SUBCC I $D(PRCFA("MOD")),$P(PRCFA("MOD"),U,2)=1 S PRCCSCC="" G STR

 I $D(PRCFMO("SCC")),PRCFMO("SCC")="Y" S PRCCSCC="00"

 I '$D(PRCFMO("SCC")) S PRCCSCC=""

 I $D(PRCFMO("SCC")),PRCFMO("SCC")="N" S PRCCSCC=""

 I $D(PRCFMO("SCC")),PRCFMO("SCC")="O" S PRCCSCC="00"

STR S $P(STR2,U,6)=PRCCCC,$P(STR2,U,7)=PRCCSCC

 S $P(STR2,U,8)=$P(PRCSTR,U,3)

 Q STR2

SA ;LOOKUP FOR INVALID BOCS  - CALLED FROM GECS INPUT TRANSFORM

 S DIR(0)="Y",DIR("B")="NO"

 S DIR("A")="  Use this BOC anyway",DIR("A",1)="  Invalid BOC number"

 S DIR("?")="  Enter 'NO' or 'N' or 'RETURN' if you do not wish to use this BOC"

 S DIR("?",1)="  Enter 'YES' or 'Y' to use this BOC"

 D ^DIR K DIR

 I 'Y!($D(DIRUT)) K X Q

 S X=ZC K ZC Q

MANCC ;LOOKUP FOR INVALID COST CENTER - CALLED FROM GECS INPUT TRANSFORM

 S DIR(0)="Y",DIR("B")="NO"

 S DIR("A")="  Use this Cost Center anyway",DIR("A",1)="  Invalid Cost Center Number"

 S DIR("?")="  Enter 'NO' or 'N' or 'RETURN' if you do not wish to use this Cost Center"

 S DIR("?",1)="  Enter 'YES' or 'Y' to use this Cost Center"

 D ^DIR K DIR

 I 'Y!($D(DIRUT)) K X Q

 S X=ZC K ZC Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFFU3   3846     printed  Apr 23, 2025@18:18:15                                                                                                                                                                                                     Page 2

PRCFFU3   ;WISC/SJG-FMS LIN,MOA,MOB,MOZ SEGMENTS ;4/27/94  1:39 PM

V         ;;5.1;IFCAP;**178**;Oct 20, 2000;Build 3

 +1       ;Per VHA Directive 2004-038, this routine should not be modified.

 +2       ;

LIN       ;BUILD 'LIN' SEGMENT

 +1        SET TMPLINE=TMPLINE+1

 +2        SET ^TMP($JOB,"PRCMO",INT,TMPLINE)="LIN^~"

 +3        QUIT

MOA       ;BUILD 'MOA' SEGMENT

 +1        NEW SEG,BOC,AMT,NUM

 +2        IF PRCFA("MP")=21

               IF (TRCODE="SO")&(TYCODE="M")

                   SET NUM=NUMB

                   Begin DoDot:1

 +3                    NEW DA

                       KILL PRCTMP

                       SET DIC=442

                       SET DR="3;7.2"

                       SET DA=+PO

                       SET DIQ="PRCTMP("

 +4                    DO EN^DIQ1

                       KILL DIC,DIQ,DR

 +5                    SET BOC=+$GET(PRCTMP(442,+PO,3))

 +6                    SET AMT=$JUSTIFY(+$GET(PRCTMP(442,+PO,7.2)),0,2)

 +7                    SET NUM=$EXTRACT("00"_NUM,$LENGTH(NUM),99)

                   End DoDot:1

                   GOTO MOASEG

 +8        SET AMT=$PIECE(FMSNOD,U,2)

           IF TYCODE="E"

               if AMT'>0

                   QUIT

 +9        SET BOC=$PIECE(FMSNOD,U)

           SET AMT=$JUSTIFY($PIECE(FMSNOD,U,2),0,2)

           SET NUMB=$PIECE(FMSNOD,U,3)

           SET NUM=$EXTRACT("00"_NUMB,$LENGTH(NUMB),99)

 +10       IF TYCODE="E"

               IF NUM=991

                   IF (FOB="D")&(+AMT=0)

                       QUIT

 +11       IF TYCODE="M"

               IF '$DATA(PRCFCHG("BOC",BOC,NUMB))

                   QUIT

 +12       IF TYCODE="M"

               IF $DATA(PRCFCHG("BOC",BOC,NUMB))

                   Begin DoDot:1

 +13                   SET AMT=$JUSTIFY($PIECE(PRCFCHG("BOC",BOC,NUMB),U,2),0,2)

 +14                   SET IDFLAG=$PIECE(PRCFCHG("BOC",BOC,NUMB),U,4)

                   End DoDot:1

MOASEG     SET TMPLINE=TMPLINE+1

           SET SEG=""

 +1        SET SEG=NUM

           SET $PIECE(SEG,U,5)=PRCBUD

           SET $PIECE(SEG,U,13)=BOC

 +2        IF $DATA(PRCFMO("JOB"))

               IF PRCFMO("JOB")="Y"

                   SET $PIECE(SEG,U,15)=$PIECE(PRCSTR,U,10)

 +3        IF $DATA(PRCFMO("RC"))

               IF PRCFMO("RC")="Y"

                   SET $PIECE(SEG,U,16)=""

 +4        SET $PIECE(SEG,U,17)=AMT

           SET $PIECE(SEG,U,18)=IDFLAG

 +5        SET ^TMP($JOB,"PRCMO",INT,TMPLINE)="LIN^~MOA^"_SEG_"^~"

 +6        QUIT

MOB       ;BUILD 'MOB' SEGMENT

 +1        NEW SEG

 +2        SET TMPLINE=TMPLINE+1

           SET SEG=""

 +3        SET ^TMP($JOB,"PRCMO",INT,TMPLINE)="MOB^~"

 +4        IF SEG

               SET ^TMP($JOB,"PRCMO",INT,TMPLINE)="MOB^"_SEG_"^~"

 +5        QUIT

MOZ       ;BUILD 'MOZ' SEGMENT

 +1        NEW SEG

 +2        SET TMPLINE=TMPLINE+1

           SET SEG=""

 +3        SET ^TMP($JOB,"PRCMO",INT,TMPLINE)="MOZ^~"

 +4        IF SEG

               SET ^TMP($JOB,"PRCMO",INT,TMPLINE)="MOZ^"_SEG_"^~"

 +5        QUIT

BUD(STR1) ;BUILD BUDGET STRING

 +1        NEW BFY,EFY

           SET STR2=""

 +2        SET BFY=$EXTRACT($PIECE(PRCSTR,U,6),3,4)

           SET EFY=$EXTRACT($PIECE(PRCSTR,U,7),3,4)

 +3        SET $PIECE(STR2,U)=BFY

 +4        IF BFY=EFY

               SET $PIECE(STR2,U,2)=""

 +5        IF BFY'=EFY

               SET $PIECE(STR2,U,2)=EFY

 +6        SET STR2=STR2_"^"_$PIECE(PRCSTR,U,5)

SITE       IF $DATA(PRCFMO("SITE"))

               IF PRCFMO("SITE")="Y"

                   SET $PIECE(STR2,U,4)=PRC("SITE")

 +1        IF '$DATA(PRCFMO("SITE"))

               SET $PIECE(STR2,U,4)=""

 +2        IF $DATA(PRCFMO("SITE"))

               IF PRCFMO("SITE")="N"

                   SET $PIECE(STR2,U,4)=""

 +3        IF $DATA(PRCFMO("SITE"))

               IF PRCFMO("SITE")="O"

                   SET $PIECE(STR2,U,4)=PRC("SITE")

SAT        KILL PRCTMP(442,+PO,31)

           DO GENDIQ^PRCFFU7(442,+PO,31,"IEN","")

 +1        SET SATSTN=$GET(PRCTMP(442,+PO,31,"E"))

 +2        IF SATSTN]""

               SET SATSTN=$EXTRACT(SATSTN,4,5)

               IF SATSTN=""

                   SET SATSTN="  "

 +3        SET $PIECE(STR2,U,5)=SATSTN

 +4       ;PRC*5.1*178 modifies Cost Center field to include entire 6 digit FCP Cost Center

CC         IF $DATA(PRCFMO("CC"))

               IF PRCFMO("CC")="Y"

                   SET PRCCCC=$EXTRACT(PRCCC,1,6)

                   SET PRCCCC=PRCCCC_$EXTRACT("000000",1,6-$LENGTH(PRCCCC))

                   SET PRCCCC=PRCCCC_"^"

 +1        IF '$DATA(PRCFMO("CC"))

               SET PRCCCC=""

 +2        IF $DATA(PRCFMO("CC"))

               IF PRCFMO("CC")="N"

                   SET PRCCCC=""

 +3        IF $DATA(PRCFMO("CC"))

               IF PRCFMO("CC")="O"

                   SET PRCCCC=$EXTRACT(PRCCC,1,6)

                   SET PRCCCC=PRCCCC_$EXTRACT("000000",1,6-$LENGTH(PRCCCC))

                   SET PRCCCC=PRCCCC_"^"

 +4       ;PRC*5.1*178 modifies Sub Cost Center field to '00'

SUBCC      IF $DATA(PRCFA("MOD"))

               IF $PIECE(PRCFA("MOD"),U,2)=1

                   SET PRCCSCC=""

                   GOTO STR

 +1        IF $DATA(PRCFMO("SCC"))

               IF PRCFMO("SCC")="Y"

                   SET PRCCSCC="00"

 +2        IF '$DATA(PRCFMO("SCC"))

               SET PRCCSCC=""

 +3        IF $DATA(PRCFMO("SCC"))

               IF PRCFMO("SCC")="N"

                   SET PRCCSCC=""

 +4        IF $DATA(PRCFMO("SCC"))

               IF PRCFMO("SCC")="O"

                   SET PRCCSCC="00"

STR        SET $PIECE(STR2,U,6)=PRCCCC

           SET $PIECE(STR2,U,7)=PRCCSCC

 +1        SET $PIECE(STR2,U,8)=$PIECE(PRCSTR,U,3)

 +2        QUIT STR2

 +3       ;

SA        ;LOOKUP FOR INVALID BOCS  - CALLED FROM GECS INPUT TRANSFORM

 +1        SET DIR(0)="Y"

           SET DIR("B")="NO"

 +2        SET DIR("A")="  Use this BOC anyway"

           SET DIR("A",1)="  Invalid BOC number"

 +3        SET DIR("?")="  Enter 'NO' or 'N' or 'RETURN' if you do not wish to use this BOC"

 +4        SET DIR("?",1)="  Enter 'YES' or 'Y' to use this BOC"

 +5        DO ^DIR

           KILL DIR

 +6        IF 'Y!($DATA(DIRUT))

               KILL X

               QUIT

 +7        SET X=ZC

           KILL ZC

           QUIT

 +8        QUIT

MANCC     ;LOOKUP FOR INVALID COST CENTER - CALLED FROM GECS INPUT TRANSFORM

 +1        SET DIR(0)="Y"

           SET DIR("B")="NO"

 +2        SET DIR("A")="  Use this Cost Center anyway"

           SET DIR("A",1)="  Invalid Cost Center Number"

 +3        SET DIR("?")="  Enter 'NO' or 'N' or 'RETURN' if you do not wish to use this Cost Center"

 +4        SET DIR("?",1)="  Enter 'YES' or 'Y' to use this Cost Center"

 +5        DO ^DIR

           KILL DIR

 +6        IF 'Y!($DATA(DIRUT))

               KILL X

               QUIT

 +7        SET X=ZC

           KILL ZC

           QUIT

 +8        QUIT

PRCFFU3.m