PRCFFU3A.m

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 ---PRCFFU3A   1760     printed  Feb 18, 2025@23:30:10                                                                                                                                                                                                    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