PRCFFU2A.m

PRCFFU2A ;WISC/SJG-FMS RC2&RC3 SEGMENTS ;11/29/93  09:45

V ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 ;

RC2(NODE,TYCODE) ;BUILD 'RC2' SEGMENT

 ;

 ;PRCTMP ARRAY:

 ; file 440   .01 (Name)           .06 (Federal source), 

 ;             34 (Vendor code)     35 (Alternate address)

 ;

 ; file 442   .1  (P.O. date)        5 (Vendor)

 ;

 N SEG,VEND,FMSVENID,X

 S TMPLINE=TMPLINE+1

 S SEG="RC2^^^^^^"_TYCODE

 K PRCTMP N DA

 S DIC=442,DR=".1;5",DA=+PO,DIQ="PRCTMP(",DIQ(0)="IE"

 D EN^DIQ1

 K DIC,DIQ,DR

 ;

 S (BEGDATE,PODATE,X)=PRCFA("OBLDATE")

 S $P(SEG,U,2)=$E(X,2,3) ; year

 S $P(SEG,U,3)=$E(X,4,5) ; month

 S $P(SEG,U,4)=$E(X,6,7) ; day

 ;

 S $P(SEG,U,5)="SO"

 S $P(SEG,U,6)=$TR(PRCFA("REF"),"-","")_"  "

 ;

RC2Q S $P(SEG,U,16)="ADJUSTMENT AR"

 ;

 S ^TMP($J,"PRCMO",INT,TMPLINE)=SEG_"^~"

 K PRCTMP

 Q

 ;

RC3 S TMPLINE=TMPLINE+1

 S SEG="RC3^^01"

 S X=$P($G(PRCFA("ACCPD")),U)

 S $P(SEG,U,4)=$E(X,1,2) ; ACCT month

 S $P(SEG,U,5)=$E(X,3,4) ; ACCT year

 S ^TMP($J,"PRCMO",INT,TMPLINE)=SEG_"^~"

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCFFU2A   1084     printed  Apr 09, 2024@21:16:18                                                                                                                                                                                                    Page 2

PRCFFU2A  ;WISC/SJG-FMS RC2&RC3 SEGMENTS ;11/29/93  09:45

V         ;;5.1;IFCAP;;Oct 20, 2000

 +1       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +2       ;

RC2(NODE,TYCODE) ;BUILD 'RC2' SEGMENT

 +1       ;

 +2       ;PRCTMP ARRAY:

 +3       ; file 440   .01 (Name)           .06 (Federal source), 

 +4       ;             34 (Vendor code)     35 (Alternate address)

 +5       ;

 +6       ; file 442   .1  (P.O. date)        5 (Vendor)

 +7       ;

 +8        NEW SEG,VEND,FMSVENID,X

 +9        SET TMPLINE=TMPLINE+1

 +10       SET SEG="RC2^^^^^^"_TYCODE

 +11       KILL PRCTMP

           NEW DA

 +12       SET DIC=442

           SET DR=".1;5"

           SET DA=+PO

           SET DIQ="PRCTMP("

           SET DIQ(0)="IE"

 +13       DO EN^DIQ1

 +14       KILL DIC,DIQ,DR

 +15      ;

 +16       SET (BEGDATE,PODATE,X)=PRCFA("OBLDATE")

 +17      ; year

           SET $PIECE(SEG,U,2)=$EXTRACT(X,2,3)

 +18      ; month

           SET $PIECE(SEG,U,3)=$EXTRACT(X,4,5)

 +19      ; day

           SET $PIECE(SEG,U,4)=$EXTRACT(X,6,7)

 +20      ;

 +21       SET $PIECE(SEG,U,5)="SO"

 +22       SET $PIECE(SEG,U,6)=$TRANSLATE(PRCFA("REF"),"-","")_"  "

 +23      ;

RC2Q       SET $PIECE(SEG,U,16)="ADJUSTMENT AR"

 +1       ;

 +2        SET ^TMP($JOB,"PRCMO",INT,TMPLINE)=SEG_"^~"

 +3        KILL PRCTMP

 +4        QUIT 

 +5       ;

RC3        SET TMPLINE=TMPLINE+1

 +1        SET SEG="RC3^^01"

 +2        SET X=$PIECE($GET(PRCFA("ACCPD")),U)

 +3       ; ACCT month

           SET $PIECE(SEG,U,4)=$EXTRACT(X,1,2)

 +4       ; ACCT year

           SET $PIECE(SEG,U,5)=$EXTRACT(X,3,4)

 +5        SET ^TMP($JOB,"PRCMO",INT,TMPLINE)=SEG_"^~"

 +6        QUIT