source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFFU3.m@ 1582

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