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

Last change on this file since 1259 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.4 KB
Line 
1PRCFFU3 ;WISC/SJG-FMS LIN,MOA,MOB,MOZ SEGMENTS ;4/27/94 1:39 PM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5LIN ;BUILD 'LIN' SEGMENT
6 S TMPLINE=TMPLINE+1
7 S ^TMP($J,"PRCMO",INT,TMPLINE)="LIN^~"
8 Q
9MOA ;BUILD 'MOA' SEGMENT
10 N SEG,BOC,AMT,NUM
11 I PRCFA("MP")=21 I (TRCODE="SO")&(TYCODE="M") S NUM=NUMB D G MOASEG
12 .N DA K PRCTMP S DIC=442,DR="3;7.2",DA=+PO,DIQ="PRCTMP("
13 .D EN^DIQ1 K DIC,DIQ,DR
14 .S BOC=+$G(PRCTMP(442,+PO,3))
15 .S AMT=$J(+$G(PRCTMP(442,+PO,7.2)),0,2)
16 .S NUM=$E("00"_NUM,$L(NUM),99)
17 S AMT=$P(FMSNOD,U,2) I TYCODE="E" Q:AMT'>0
18 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)
19 I TYCODE="E" I NUM=991 I (FOB="D")&(+AMT=0) Q
20 I TYCODE="M",'$D(PRCFCHG("BOC",BOC,NUMB)) Q
21 I TYCODE="M",$D(PRCFCHG("BOC",BOC,NUMB)) D
22 .S AMT=$J($P(PRCFCHG("BOC",BOC,NUMB),U,2),0,2)
23 .S IDFLAG=$P(PRCFCHG("BOC",BOC,NUMB),U,4)
24MOASEG S TMPLINE=TMPLINE+1,SEG=""
25 S SEG=NUM,$P(SEG,U,5)=PRCBUD,$P(SEG,U,13)=BOC
26 I $D(PRCFMO("JOB")),PRCFMO("JOB")="Y" S $P(SEG,U,15)=$P(PRCSTR,U,10)
27 I $D(PRCFMO("RC")),PRCFMO("RC")="Y" S $P(SEG,U,16)=""
28 S $P(SEG,U,17)=AMT,$P(SEG,U,18)=IDFLAG
29 S ^TMP($J,"PRCMO",INT,TMPLINE)="LIN^~MOA^"_SEG_"^~"
30 QUIT
31MOB ;BUILD 'MOB' SEGMENT
32 N SEG
33 S TMPLINE=TMPLINE+1,SEG=""
34 S ^TMP($J,"PRCMO",INT,TMPLINE)="MOB^~"
35 I SEG S ^TMP($J,"PRCMO",INT,TMPLINE)="MOB^"_SEG_"^~"
36 Q
37MOZ ;BUILD 'MOZ' SEGMENT
38 N SEG
39 S TMPLINE=TMPLINE+1,SEG=""
40 S ^TMP($J,"PRCMO",INT,TMPLINE)="MOZ^~"
41 I SEG S ^TMP($J,"PRCMO",INT,TMPLINE)="MOZ^"_SEG_"^~"
42 Q
43BUD(STR1) ;BUILD BUDGET STRING
44 N BFY,EFY S STR2=""
45 S BFY=$E($P(PRCSTR,U,6),3,4),EFY=$E($P(PRCSTR,U,7),3,4)
46 S $P(STR2,U)=BFY
47 I BFY=EFY S $P(STR2,U,2)=""
48 I BFY'=EFY S $P(STR2,U,2)=EFY
49 S STR2=STR2_"^"_$P(PRCSTR,U,5)
50SITE I $D(PRCFMO("SITE")),PRCFMO("SITE")="Y" S $P(STR2,U,4)=PRC("SITE")
51 I '$D(PRCFMO("SITE")) S $P(STR2,U,4)=""
52 I $D(PRCFMO("SITE")),PRCFMO("SITE")="N" S $P(STR2,U,4)=""
53 I $D(PRCFMO("SITE")),PRCFMO("SITE")="O" S $P(STR2,U,4)=PRC("SITE")
54SAT K PRCTMP(442,+PO,31) D GENDIQ^PRCFFU7(442,+PO,31,"IEN","")
55 S SATSTN=$G(PRCTMP(442,+PO,31,"E"))
56 I SATSTN]"" S SATSTN=$E(SATSTN,4,5) I SATSTN="" S SATSTN=" "
57 S $P(STR2,U,5)=SATSTN
58CC I $D(PRCFMO("CC")),PRCFMO("CC")="Y" S PRCCCC=$E(PRCCC,1,4)_"00^"
59 I '$D(PRCFMO("CC")) S PRCCCC=""
60 I $D(PRCFMO("CC")),PRCFMO("CC")="N" S PRCCCC=""
61 I $D(PRCFMO("CC")),PRCFMO("CC")="O" S PRCCCC=$E(PRCCC,1,4)_"00^"
62SUBCC I $D(PRCFA("MOD")),$P(PRCFA("MOD"),U,2)=1 S PRCCSCC="" G STR
63 I $D(PRCFMO("SCC")),PRCFMO("SCC")="Y" S PRCCSCC=$E(PRCCC,5,6)
64 I '$D(PRCFMO("SCC")) S PRCCSCC=""
65 I $D(PRCFMO("SCC")),PRCFMO("SCC")="N" S PRCCSCC=""
66 I $D(PRCFMO("SCC")),PRCFMO("SCC")="O" S PRCCSCC=$E(PRCCC,5,6)
67STR S $P(STR2,U,6)=PRCCCC,$P(STR2,U,7)=PRCCSCC
68 S $P(STR2,U,8)=$P(PRCSTR,U,3)
69 Q STR2
70 ;
71SA ;LOOKUP FOR INVALID BOCS - CALLED FROM GECS INPUT TRANSFORM
72 S DIR(0)="Y",DIR("B")="NO"
73 S DIR("A")=" Use this BOC anyway",DIR("A",1)=" Invalid BOC number"
74 S DIR("?")=" Enter 'NO' or 'N' or 'RETURN' if you do not wish to use this BOC"
75 S DIR("?",1)=" Enter 'YES' or 'Y' to use this BOC"
76 D ^DIR K DIR
77 I 'Y!($D(DIRUT)) K X Q
78 S X=ZC K ZC Q
79 Q
80MANCC ;LOOKUP FOR INVALID COST CENTER - CALLED FROM GECS INPUT TRANSFORM
81 S DIR(0)="Y",DIR("B")="NO"
82 S DIR("A")=" Use this Cost Center anyway",DIR("A",1)=" Invalid Cost Center Number"
83 S DIR("?")=" Enter 'NO' or 'N' or 'RETURN' if you do not wish to use this Cost Center"
84 S DIR("?",1)=" Enter 'YES' or 'Y' to use this Cost Center"
85 D ^DIR K DIR
86 I 'Y!($D(DIRUT)) K X Q
87 S X=ZC K ZC Q
88 Q
Note: See TracBrowser for help on using the repository browser.