- 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 23, 2025@18:34:12 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
