source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFD8L.m@ 1692

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

initial load of WorldVistAEHR
File size: 3.5 KB
Line 
1PRCFD8L ;WISC/LEM-FMS LIN,PVA,PVB,PVZ SEGMENTS ;7/24/97 14:07
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5LIN ;BUILD 'LIN' SEGMENT
6 S DA(421.541)=LINE,DR="1;2;3;14;41" D EN^DIQ1
7 S ^TMP($J,"PRCPV",LINE*4+1)="LIN^~"
8 Q
9PVA ;BUILD 'PVA' SEGMENT
10 N SEG,ACCDATE,X1,X2,SERVDATE,CERTDATE
11 S (SEG,ACCDATE)=""
12 S (X2,SERVDATE)=PRCTMP(421.5,DA,11.5,"I")
13 S (X1,CERTDATE)=PRCTMP(421.5,DA,61.9,"I")
14 I X2,'X1 D
15 . S X1=X2,X2=7 D C^%DTC S ACCDATE=X Q
16 I SERVDATE,CERTDATE D
17 . S X1=CERTDATE,X2=SERVDATE D ^%DTC
18 . I X<8 S ACCDATE=CERTDATE Q
19 . I X>7 S X1=SERVDATE,X2=7 D C^%DTC S ACCDATE=X Q
20 S $P(SEG,U,1)="PVA" ; Segment ID
21 S X="000"_PRCTMP(421.541,DA(421.541),4,"E")
22 S $P(SEG,U,2)=$E(X,$L(X)-2,$L(X)) ; FMS Line Number
23 S $P(SEG,U,3)=PRCF("TC") ; Reference Document Transaction Code
24 S $P(SEG,U,4)=PRCF("TN") ; Transaction Number
25 S $P(SEG,U,5)=$P(SEG,U,2) ; Reference Document FMS Line Number
26 S $P(SEG,U,6)=$E(ACCDATE,2,3) ; Accept Year
27 S $P(SEG,U,7)=$E(ACCDATE,4,5) ; Accept Month
28 S $P(SEG,U,8)=$E(ACCDATE,6,7) ; Accept Day
29 S $P(SEG,U,21)=PRCTMP(421.541,DA(421.541),.01,"I") ; BOC
30 S X=PRCTMP(421.5,CI,2,"I")
31 S $P(SEG,U,29)=$E(X,2,3) ; Vendor's Invoice Year
32 S $P(SEG,U,30)=$E(X,4,5) ; Vendor's Invoice Month
33 S $P(SEG,U,31)=$E(X,6,7) ; Vendor's Invoice Day
34 S X=PRCTMP(421.541,DA(421.541),1,"I")
35 S $P(SEG,U,33)=$FN(X,"",2) ; Line Amount
36 S $P(SEG,U,34)="I" ;PRCTMP(421.541,DA(421.541),5,"I") ; Line Action (Increase/Decrease)
37 S $P(SEG,U,35)=PRCTMP(421.541,DA(421.541),3,"I") ; Partial/Final Indicator
38 S X=PRCTMP(421.5,CI,3,"I")
39 S $P(SEG,U,36)=$E(X,2,3) ; Year Invoice Logged
40 S $P(SEG,U,37)=$E(X,4,5) ; Month Invoice Logged
41 S $P(SEG,U,38)=$E(X,6,7) ; Day Invoice Logged
42 S X="" I PRCTMP(421.541,DA(421.541),4,"E")=991 S X="F"
43 S $P(SEG,U,39)=X ; Line Type
44 S $P(SEG,U,41)="~" ; Segment Delimiter
45 S ^TMP($J,"PRCPV",LINE*4+2)=SEG
46 Q
47PVB ;BUILD 'PVB' SEGMENT
48 N SEG
49 S SEG="",$P(SEG,U,1)="PVB"
50 Q:+PRCTMP(421.541,DA(421.541),2,"I")=PRCTMP(421.541,DA(421.541),1,"I")
51 I PRCTMP(421.541,DA(421.541),2,"I")]"" D
52 . S $P(SEG,U,8)=$FN(PRCTMP(421.541,DA(421.541),2,"I"),"",2) ; Liquidation Amount
53 . S SEG=SEG_"^~",^TMP($J,"PRCPV",LINE*4+3)=SEG
54 Q
55PVC ;BUILD 'PVC' SEGMENT
56 Q ; No data for now - Don't send PVC segment.
57 N SEG
58 S SEG="",$P(SEG,U,1)="PVC",$P(SEG,U,5)="~"
59 S ^TMP($J,"PRCPV",LINE*4+4)=SEG
60 Q
61 ;
62CVNFY(A,B) ;return conversion FY
63 N X,Y,Z S X="",Y=$O(^DIC(9.4,"B",A,"")) Q:Y="" X
64 S Z=0 F S Z=$O(^DIC(9.4,Y,22,Z)) Q:+Z'>0 I $E($G(^DIC(9.4,Y,22,Z,0)),1,$L(B))=B Q
65 Q:+Z'>0 X
66 S X=$P(^DIC(9.4,Y,22,Z,0),U,3)
67 S:X X=$E(X,1,3)+1700+$S(+$E(X,4,5)>9:1,1:0)
68 Q X
69 ;
70 ; USER OPTION TO SET UP SO to AR DATE
71SOAR N DIR,X,X1,X2,PRCSOAR
72SOAR0 S DIR(0)="D^DT:"_(DT+10000)_":EFX"
73 S DIR("B")=$$FMTE^XLFDT($G(^PRC(411,"A IFCAP-Wide Parameters","SO 2 AR Date"))) S:DIR("B")="" DIR("B")="10/12"
74 S DIR("A")=" "
75 S DIR("A",1)="Enter the date on which FMS will accrue their prior year documents."
76 S DIR("?")="The MM/DD/YY is provided by Central Office/FMS, normally via MailMan"
77 D ^DIR I Y="^" G SOARQ
78 I Y'>0 G SOAR0
79 W !
80 S PRCSOAR=Y
81 S X1=Y,X2=1 D C^%DTC
82 S DIR("A")="Is this correct?"
83 S DIR("A",1)="IFCAP will allow 'SO's to be sent to Austin as 'AR's starting on "_$$FMTE^XLFDT(X,2)_"."
84 S DIR(0)="Y"
85 S DIR("B")="NO"
86 S DIR("?")="Enter 'Y' to accept your entry, 'N' to change it"
87 D ^DIR I $D(DIRUT) G SOARQ
88 I Y S ^PRC(411,"A IFCAP-Wide Parameters","SO 2 AR Date")=PRCSOAR G SOARQ
89 I 'Y W !! G SOAR0
90SOARQ Q
91 ;
92SOARINIT S ^PRC(411,"A IFCAP-Wide Parameters","SO 2 AR Date")=2961004 Q
Note: See TracBrowser for help on using the repository browser.