source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFDT.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 3.2 KB
Line 
1PRCFDT ;WISC/LEM-PROVIDE 'NET' PERCENT TRANSFORMS ;8/11/95 09:35
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4INPUT N X0 S X0=$TR(X,"net","NET")
5 I X]"",$E("NET",1,$L(X0))=X0 S X=0 Q
6 ; Native FileMan Input Transform follows:
7 K:+X'=X!(X>99.999)!(X<0)!(X?.E1"."4N.N) X
8 Q
9OUTPUT I Y?1"0"."."."0" S Y="NET"
10 Q
11 N DA S DA(1)=$G(PRCF("CIDA")) Q:DA(1)=""
12 N NODE S NODE=$G(^PRCF(421.5,DA(1),5,0))
13 I NODE="" S ^PRCF(421.5,DA(1),5,0)=U_$P(^DD(421.5,41,0),U,2)
14 N CTR,I S (CTR,I)=0 F S I=$O(PRCFD(I)) Q:I'>0 D
15 . S CTR=$S(I=991:CTR,1:CTR+1),CTR=$S(CTR=991:992,1:CTR)
16 . N DIC S DIC="^PRCF(421.5,"_DA(1)_",5,",DIC(0)="L"
17 . S X=$P(PRCFD(I),U,1),AMT=+$P(PRCFD(I),U,2)
18 . K DD,DO D FILE^DICN I Y'>0 W "ERROR" Q
19 . N DIE S DIE=DIC,DA=+Y,FMSL=$S(I=991:991,1:CTR)
20 . N DR S DR="1////^S X=AMT;2////^S X=FMSL" D ^DIE
21 . Q
22 Q
23DISC ; COMPUTE FMS LINE LIQ AMT FROM TOTAL AMT & DISCOUNT TERMS
24 ; INPUT: PRCF("CIDA") - IEN FOR PAYMENT/INVOICE TRACKING RECORD
25 ; PRCFA("LAMT") - AMOUNT CERTIFIED FOR THIS INVOICE
26 ; OUTPUT: PRCFA("LIQ") - FMS COMPUTED LIQUIDATION AMOUNT
27 Q:'$D(PRCF("CIDA"))!'$D(PRCFA("LAMT"))
28 N I,DISC,HIGHDISC S (HIGHDISC,I)=0
29 F S I=$O(^PRCF(421.5,PRCF("CIDA"),6,I)) Q:+I'=I D
30 . S DISC=+$P($G(^PRCF(421.5,PRCF("CIDA"),6,I,0)),U,3)
31 . I DISC>HIGHDISC S HIGHDISC=DISC
32 . Q
33 S PRCFA("LIQ")=$FN(1-(HIGHDISC/100)*PRCFA("LAMT"),"",2)
34 Q
35SUM ;
36 ; INPUT: PRCF("CIDA") - IEN FOR PAYMENT/INVOICE TRACKING RECORD
37 ; PRCFA("CAMT") - TOTAL INVOICE AMOUNT CERTIFIED FOR PAYMENT
38 ; OUTPUT: OK - 1 IF SUM OF LINE AMOUNTS = TOTAL AMOUNT CERTIFIED
39 ; - 0 IF AMOUNTS NOT EQUAL
40 Q:'$D(PRCF("CIDA"))!'$D(PRCF("CAMT"))
41 N I,LAMT S (I,OK,PRCF("TAMT"))=0
42 F S I=$O(^PRCF(421.5,PRCF("CIDA"),5,I)) Q:+I'=I D
43 . S LAMT=+$P($G(^PRCF(421.5,PRCF("CIDA"),5,I,0)),U,2)
44 . S PRCF("TAMT")=PRCF("TAMT")+LAMT
45 . Q
46 I PRCF("CAMT")/100=PRCF("TAMT") S OK=1
47 Q
48SCREEN ; CHECK BOC
49 I $G(X) I $D(PRCFX("SA",+X))
50 Q
51OBLIG(PRCA) ; Check for an original entry SO or MO on the P.O.
52 S PRCA="" Q:'$D(PRCF("PODA")) 0 Q:'$D(^PRC(442,PRCF("PODA"))) 0
53 N DOC,PRCI,X S PRCI=0
54 F S PRCI=$O(^PRC(442,PRCF("PODA"),10,PRCI)) Q:+PRCI'=PRCI D Q:PRCA>0
55 . S DOC=$P($G(^PRC(442,PRCF("PODA"),10,PRCI,0)),".",1,2)
56 . I DOC="SO.E"!(DOC="MO.E") S PRCA=PRCI Q
57 . I $P(DOC,".")=921,";00;01;02;03;04;05;06;08;09;10;11;12;13;14;15;16;18;20;21;22;23;24;25;26;27;60;41;51;53;71;91;93;97;"[(";"_$P(DOC,".",2)_";") S PRCA=PRCI Q
58 . I ";1;2;"[(";"_$P($G(^PRC(442,PRCF("PODA"),0)),U,19)_";"),DOC="SO.M"!(DOC="MO.M") D
59 . . S X="GECSSGET" X ^%ZOSF("TEST") Q:'$T
60 . . S X=$P($G(^PRC(442,PRCF("PODA"),10,PRCI,0)),U,4) Q:X=""
61 . . N GECSDATA
62 . . D DATA^GECSSGET(X,0) Q:'$G(GECSDATA)
63 . . I $G(GECSDATA(2100.1,GECSDATA,4,"E"))["Supply Fund Conversion Modification" S PRCA=PRCI Q
64 . . I $G(GECSDATA(2100.1,GECSDATA,4,"E"))["General Post Fund Conversion Modification" S PRCA=PRCI Q
65 . Q
66 Q $S(PRCA>0:1,1:0)
67LOOKUP(X,PARTIAL) ; X = STA-PAT # - LOOKUP returns next available PARTIAL #.
68 N DIC S DIC="^PRCF(421.9,",DIC(0)="O" K DD,DO D ^DIC
69 I Y<0 D FILE^DICN
70 I +Y,$P(Y,U,3)=1 S PARTIAL="01",$P(^PRCF(421.9,+Y,0),U,2)="01" Q
71 S P=$P($G(^PRCF(421.9,+Y,0)),U,2),P=P+1
72 S P="00"_P,P=$E(P,$L(P)-1,$L(P))
73 S PARTIAL=P,$P(^PRCF(421.9,+Y,0),U,2)=P
74 Q
Note: See TracBrowser for help on using the repository browser.