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^~"
Q
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_"^~"
Q
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_"^~"
Q
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
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFFU3 3846 printed Nov 22, 2024@17:13:52 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
