89 lines
3.4 KiB
Mathematica
89 lines
3.4 KiB
Mathematica
PRCFFU3 ;WISC/SJG-FMS LIN,MOA,MOB,MOZ SEGMENTS ;4/27/94 1:39 PM
|
|
V ;;5.1;IFCAP;;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, 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
|
|
CC I $D(PRCFMO("CC")),PRCFMO("CC")="Y" S PRCCCC=$E(PRCCC,1,4)_"00^"
|
|
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,4)_"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=$E(PRCCC,5,6)
|
|
I '$D(PRCFMO("SCC")) S PRCCSCC=""
|
|
I $D(PRCFMO("SCC")),PRCFMO("SCC")="N" S PRCCSCC=""
|
|
I $D(PRCFMO("SCC")),PRCFMO("SCC")="O" S PRCCSCC=$E(PRCCC,5,6)
|
|
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
|