source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFFU2A.m@ 1801

Last change on this file since 1801 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 1.0 KB
RevLine 
[613]1PRCFFU2A ;WISC/SJG-FMS RC2&RC3 SEGMENTS ;11/29/93 09:45
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5RC2(NODE,TYCODE) ;BUILD 'RC2' SEGMENT
6 ;
7 ;PRCTMP ARRAY:
8 ; file 440 .01 (Name) .06 (Federal source),
9 ; 34 (Vendor code) 35 (Alternate address)
10 ;
11 ; file 442 .1 (P.O. date) 5 (Vendor)
12 ;
13 N SEG,VEND,FMSVENID,X
14 S TMPLINE=TMPLINE+1
15 S SEG="RC2^^^^^^"_TYCODE
16 K PRCTMP N DA
17 S DIC=442,DR=".1;5",DA=+PO,DIQ="PRCTMP(",DIQ(0)="IE"
18 D EN^DIQ1
19 K DIC,DIQ,DR
20 ;
21 S (BEGDATE,PODATE,X)=PRCFA("OBLDATE")
22 S $P(SEG,U,2)=$E(X,2,3) ; year
23 S $P(SEG,U,3)=$E(X,4,5) ; month
24 S $P(SEG,U,4)=$E(X,6,7) ; day
25 ;
26 S $P(SEG,U,5)="SO"
27 S $P(SEG,U,6)=$TR(PRCFA("REF"),"-","")_" "
28 ;
29RC2Q S $P(SEG,U,16)="ADJUSTMENT AR"
30 ;
31 S ^TMP($J,"PRCMO",INT,TMPLINE)=SEG_"^~"
32 K PRCTMP
33 Q
34 ;
35RC3 S TMPLINE=TMPLINE+1
36 S SEG="RC3^^01"
37 S X=$P($G(PRCFA("ACCPD")),U)
38 S $P(SEG,U,4)=$E(X,1,2) ; ACCT month
39 S $P(SEG,U,5)=$E(X,3,4) ; ACCT year
40 S ^TMP($J,"PRCMO",INT,TMPLINE)=SEG_"^~"
41 Q
Note: See TracBrowser for help on using the repository browser.