PRCFFU3A ;WISC/SJG-FMS LIN,RCA,RCB,RCC SEGMENTS (AR TRANSACTION);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.
;
;BUILD 'LIN' SEGMENT
LIN S TMPLINE=TMPLINE+1
S ^TMP($J,"PRCMO",INT,TMPLINE)="LIN^~"
Q
;
;BUILD 'RCA' SEGMENT
RCA N SEG,BOC,AMT,NUM,FOB
S FOB=""
I $D(PRCFA("FOB")),TYCODE'="M"!(PRCFA("FOB")]"") S FOB=$G(PRCTMP(442,+PO,6.4,"I")) I FOB="" S FOB="D"
I PRCFA("MP")=21,TRCODE'="MO",TYCODE="M" D G MOASEG
.S BOC=+$P(TRNODE(3),"^",6)
.S AMT=$J($P(TRNODE(4),"^",8),0,2)
.S NUM=$E("00"_NUMB,$L(NUMB),99)
; POs, MOs, orig 1358
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=""
I TYCODE="E" S $P(SEG,U,21)="01"
S $P(SEG,U,19)=NUM,$P(SEG,U,20)=NUM,$P(SEG,U,22)=PRCBUD,$P(SEG,U,30)=BOC
I $D(PRCFMO("JOB")),PRCFMO("JOB")="Y" S $P(SEG,U,32)=$P(PRCSTR,U,10)
I $D(PRCFMO("RC")),PRCFMO("RC")="Y" S $P(SEG,U,33)=""
S $P(SEG,U,34)=$FN(AMT,"-",2),$P(SEG,U,35)=IDFLAG
I IDFLAG="D" S $P(SEG,U,36)="F"
S ^TMP($J,"PRCMO",INT,TMPLINE)="LIN^~RCA^"_SEG_"^~"
QUIT
;
;BUILD 'RCB' SEGMENT
RCB N SEG
S TMPLINE=TMPLINE+1,SEG=""
S ^TMP($J,"PRCMO",INT,TMPLINE)="RCB^~"
I SEG S ^TMP($J,"PRCMO",INT,TMPLINE)="RCB^"_SEG_"^~"
Q
;
;BUILD 'RCC' SEGMENT
RCC N SEG
S TMPLINE=TMPLINE+1,SEG=""
S ^TMP($J,"PRCMO",INT,TMPLINE)="RCC^~"
I SEG S ^TMP($J,"PRCMO",INT,TMPLINE)="RCC^"_SEG_"^~"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFFU3A 1760 printed Nov 22, 2024@17:13:53 Page 2
PRCFFU3A ;WISC/SJG-FMS LIN,RCA,RCB,RCC SEGMENTS (AR TRANSACTION);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 ;BUILD 'LIN' SEGMENT
LIN SET TMPLINE=TMPLINE+1
+1 SET ^TMP($JOB,"PRCMO",INT,TMPLINE)="LIN^~"
+2 QUIT
+3 ;
+4 ;BUILD 'RCA' SEGMENT
RCA NEW SEG,BOC,AMT,NUM,FOB
+1 SET FOB=""
+2 IF $DATA(PRCFA("FOB"))
IF TYCODE'="M"!(PRCFA("FOB")]"")
SET FOB=$GET(PRCTMP(442,+PO,6.4,"I"))
IF FOB=""
SET FOB="D"
+3 IF PRCFA("MP")=21
IF TRCODE'="MO"
IF TYCODE="M"
Begin DoDot:1
+4 SET BOC=+$PIECE(TRNODE(3),"^",6)
+5 SET AMT=$JUSTIFY($PIECE(TRNODE(4),"^",8),0,2)
+6 SET NUM=$EXTRACT("00"_NUMB,$LENGTH(NUMB),99)
End DoDot:1
GOTO MOASEG
+7 ; POs, MOs, orig 1358
+8 SET AMT=$PIECE(FMSNOD,U,2)
IF TYCODE="E"
if AMT'>0
QUIT
+9 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)
+10 IF TYCODE="E"
IF NUM=991
IF (FOB="D")&(+AMT=0)
QUIT
+11 IF TYCODE="M"
IF '$DATA(PRCFCHG("BOC",BOC,NUMB))
QUIT
+12 IF TYCODE="M"
IF $DATA(PRCFCHG("BOC",BOC,NUMB))
Begin DoDot:1
+13 SET AMT=$JUSTIFY($PIECE(PRCFCHG("BOC",BOC,NUMB),U,2),0,2)
+14 SET IDFLAG=$PIECE(PRCFCHG("BOC",BOC,NUMB),U,4)
End DoDot:1
+15 ;
MOASEG SET TMPLINE=TMPLINE+1
SET SEG=""
+1 IF TYCODE="E"
SET $PIECE(SEG,U,21)="01"
+2 SET $PIECE(SEG,U,19)=NUM
SET $PIECE(SEG,U,20)=NUM
SET $PIECE(SEG,U,22)=PRCBUD
SET $PIECE(SEG,U,30)=BOC
+3 IF $DATA(PRCFMO("JOB"))
IF PRCFMO("JOB")="Y"
SET $PIECE(SEG,U,32)=$PIECE(PRCSTR,U,10)
+4 IF $DATA(PRCFMO("RC"))
IF PRCFMO("RC")="Y"
SET $PIECE(SEG,U,33)=""
+5 SET $PIECE(SEG,U,34)=$FNUMBER(AMT,"-",2)
SET $PIECE(SEG,U,35)=IDFLAG
+6 IF IDFLAG="D"
SET $PIECE(SEG,U,36)="F"
+7 SET ^TMP($JOB,"PRCMO",INT,TMPLINE)="LIN^~RCA^"_SEG_"^~"
+8 QUIT
+9 ;
+10 ;BUILD 'RCB' SEGMENT
RCB NEW SEG
+1 SET TMPLINE=TMPLINE+1
SET SEG=""
+2 SET ^TMP($JOB,"PRCMO",INT,TMPLINE)="RCB^~"
+3 IF SEG
SET ^TMP($JOB,"PRCMO",INT,TMPLINE)="RCB^"_SEG_"^~"
+4 QUIT
+5 ;
+6 ;BUILD 'RCC' SEGMENT
RCC NEW SEG
+1 SET TMPLINE=TMPLINE+1
SET SEG=""
+2 SET ^TMP($JOB,"PRCMO",INT,TMPLINE)="RCC^~"
+3 IF SEG
SET ^TMP($JOB,"PRCMO",INT,TMPLINE)="RCC^"_SEG_"^~"
+4 QUIT
