PRCUFCC ;WISC/SJG-FMS LIN,MOA SEGMENTS FOR CONVERSION ONLY ;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.
;
; Routine modiifcation of PRCFFU3 for conversion processing
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 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)=""
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=""
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=""
STR S $P(STR2,U,6)=PRCCCC,$P(STR2,U,7)=PRCCSCC
S $P(STR2,U,8)=$P(PRCSTR,U,3)
Q STR2
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCUFCC 2476 printed Apr 09, 2024@21:05:34 Page 2
PRCUFCC ;WISC/SJG-FMS LIN,MOA SEGMENTS FOR CONVERSION ONLY ;4/27/94 1:39 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
+3 ; Routine modiifcation of PRCFFU3 for conversion processing
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 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)
+9 IF TYCODE="E"
IF NUM=991
IF (FOB="D")&(+AMT=0)
QUIT
+10 IF TYCODE="M"
IF '$DATA(PRCFCHG("BOC",BOC,NUMB))
QUIT
+11 IF TYCODE="M"
IF $DATA(PRCFCHG("BOC",BOC,NUMB))
Begin DoDot:1
+12 SET AMT=$JUSTIFY($PIECE(PRCFCHG("BOC",BOC,NUMB),U,2),0,2)
+13 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)=""
CC IF $DATA(PRCFMO("CC"))
IF PRCFMO("CC")="Y"
SET PRCCCC=$EXTRACT(PRCCC,1,4)_"00^"
+1 IF '$DATA(PRCFMO("CC"))
SET PRCCCC=""
+2 IF $DATA(PRCFMO("CC"))
IF PRCFMO("CC")="N"
SET PRCCCC=""
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=$EXTRACT(PRCCC,5,6)
+2 IF '$DATA(PRCFMO("SCC"))
SET PRCCSCC=""
+3 IF $DATA(PRCFMO("SCC"))
IF PRCFMO("SCC")="N"
SET PRCCSCC=""
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
