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 ---[H[J[2J[HPRCFFU2A 1084 printed Nov 22, 2024@17:13:51 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
