source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFA8.m@ 623

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

initial load of WorldVistAEHR

File size: 4.0 KB
Line 
1PRCFA8 ;WISC/CTB-PROCESS RECEIVING REPORTS ;2/2/96 13:30
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4EN8 ;PROCESSING OF RECEIVING REPORT
5 S (PRCFA("SYS"),PRCFASYS)="FMS",PRCF("X")="AS"
6 D ^PRCFSITE G:'% OUT K DIC("A")
7 S D="C",DIC("S")="I +$P(^(0),U,1)=PRC(""SITE""),$D(^(7)),+^(7)>0 S FSO=$P(^PRCD(442.3,+^(7),0),U,3) I FSO>29&(FSO<40)!(FSO=26!(FSO=41)&$$ONE2PROC^PRCFA8) I '$P($G(^PRC(442,+Y,24)),U)"
8 S DIC("A")="Select Purchase Order Number: ",DIC=442,DIC(0)="AEQZ"
9 D IX^DIC K DIC("S"),DIC("A"),FSO G:+Y<0 OUT
10 S PO(0)=Y(0),(D0,PRCFA("PODA"))=+Y,PO=Y
11 S %A="Do want to review the Purchase Order and Receiving Report"
12 I $P($G(^PRC(442,D0,11,0)),U,4)>1 S %A=%A_"s"
13 S %B="",%=2 D ^PRCFYN G OUT:%<0 I %=1 D ^PRCHDP1
14PPT N FED,PPT,I S PPT="",(FED,I)=0
15 N P7 S P7=$P($G(^PRC(442,PRCFA("PODA"),1)),U,7)
16 I P7]"","13578"[P7 S FED=2
17 ;I 'FED N PPR F S I=$O(^PRC(442,PRCFA("PODA"),5,I)) Q:+I'=I S PPR=$G(^(I,0)) D
18 ;. Q:PPR="" I $P(PPR,U,1)="NET",$P(PPR,U,5)]"" S PPT=$P(PPR,U,5)
19 ;. I PPT="" S PPT=$P(PPR,U,5)
20 ;. Q
21 S PPT=$P($G(^PRC(442,PRCFA("PODA"),12)),U,15)
22 I 'FED,PPT="" D I $D(DTOUT)!$D(DUOUT)!$D(Y) G OUT
23 . W !!,"This P.O. does not have PROMPT PAYMENT TYPE information.",!,"PLease enter the information now."
24 . S DIE="^PRC(442,",DA=PRCFA("PODA"),DR=97_"//^S X=""A""" D ^DIE K DIE,DR,DA
25 . S PPT=$P($G(^PRC(442,PRCFA("PODA"),12)),U,15)
26 . QUIT
27ACC I '$D(^PRC(442,PRCFA("PODA"),22)) D G OUT
28 . S X="This P.O. has no FMS accounting lines - Cannot process.*"
29 . D MSG^PRCFQ
30 . Q
31PAR S DIC("A")="Partial Number to PROCESS: ",DIC="^PRC(442,"_+PO_",11,"
32 S DIC("S")="I $P(^(0),U,19)="""""
33 S DIC(0)="AEQMNZ" D ^DIC K DIC("A")
34 G:Y<0 OUT S PO(11)=Y(0),PRCFA("PARTIAL")=+Y
35 ; Convert IFCAP Partial # ==> FMS Partial #
36 N PNO S PNO="" D ALPHA^PRCFPAR(PRCFA("PARTIAL"),.PNO)
37 I PNO<0 D G PAR
38 . S X="Partial # is out of limits - FMS will not process.*"
39 . D MSG^PRCFQ
40 . Q
41 N ACTION S ACTION="E"
42 S X=$P($G(^PRC(442,PRCFA("PODA"),11,PRCFA("PARTIAL"),1)),U,16)
43 I X?1.N D
44 . S X="This partial #"_PRCFA("PARTIAL")_" is an Adjustment to partial #"_X
45 . D MSG^PRCFQ
46 . S ACTION="M"
47 I $P(PO(11),U,6)="Y" W $C(7) D I %'=1 G OUT
48 . S %A="Fiscal Service has already processed this partial."
49 . S %A(1)="Do you want to enter a MODIFICATION to the original Receiving Report"
50 . S %B="",%=2 D ^PRCFYN I %'=1 K P,DIC,Y
51 . Q
52 S PO(2)=$P(PO(11),"^")\1 ;I $P(PO(0),"^",19)=2!($P(PO(0),"^",19)=3) G X
53 S DA(1)=PRCFA("PODA"),DA=PRCFA("PARTIAL")
54 S DIE="^PRC(442,"_PRCFA("PODA")_",11,",DR="23R//^S X=$P(""JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC"",U,+$E(DT,4,5))_"" ""_($E(DT,1,3)+1700)"
55 D ^DIE K DA,DIE,DR G OUT8:$D(DTOUT)!$D(DUOUT)!$D(Y)
56C N SC,DOCTYPE S (SC,DOCTYPE)="N"
57 S PRCFPO=PRCFA("PODA"),PRCFPR=PRCFA("PARTIAL"),PRCFA8=1
58 D EN^PRCFARR I $G(LCKFLG) G OUT8
59 D:$D(^TMP("PRCFARR",$J)) ^PRCFARRD
60 W:'$D(^TMP("PRCFARR",$J)) @IOF,!,"Error: Receiver Records could not be built!",!!
61 S PO=+PO
62EN82 ;
63X W !,"LIQUIDATION CODE: " R X:DTIME G OUT8:'$T,OUT8:X["^"
64 I "PCF"'[$E(X)!(X="") W ! S X="Enter a (P)artial, (F)inal, or (C)omplete only.*" D MSG^PRCFQ G X
65 S PRCFA("LIQ")=$E(X)
66 S MESSAGE="" D ESIG^PRCUESIG(DUZ,.MESSAGE)
67 I MESSAGE'=1 S X="<No Further Action Taken.>" D MSG^PRCFQ G OUT
68 I $G(PRCFA("PODA"))>0 D
69 . D EN72^PRCFAC1
70 . N XA,XB,XC,XD,GECSFMS,POESIG S GECSFMS("DA")=""
71 . S GECSFMS("DOC")="^^RR^"_$TR($P(PO(0),U),"-")_PNO
72 . K PRCFA("TT") S POESIG=1,XA="RR",XB=$S($G(ACTION)="M":1,1:0)
73 . S XC=$P(^PRC(442,PRCFA("PODA"),11,PRCFA("PARTIAL"),0),U)
74 . S XD=$P($P(PO(0),"^"),"-",2)
75 . D EN7^PRCFFU41(XA,XB,XC,XD)
76 . D LOAD^PRCFARRQ
77OUT8 K PRCFA("PODA"),PRCFA("REC"),PRCFA("PARTIAL"),%A,%B,DTOUT,DUOUT,PO,PRCF,PRCFASYS,PRCFPO,PRCFPR
78 G EN8
79OUT K %,%A,%B,%Y,B,D0,DA,DG,DIC,DIE,DIG,DIH,DIK,DIR,DIU,DIV,DIW,DLAYGO,DR,DTOUT,DUOUT,FSO,J,K,MESSAGE,P,PO,PRCF,PRCFA,PRCFASYS,PRCFPO,PRCFPR,Q,Q1,S,X,Y
80 K ^TMP("PRCFARR",$J)
81 Q
82ONE2PROC() ;Check if unsent receivers
83 N X,Z S X=0,Z=0
84 F S Z=$O(^PRC(442,Y,11,Z)) Q:Z'?1.N D Q:X
85 . Q:$D(^PRC(442,Y,11,Z,0))#10'=1
86 . S:$P(^PRC(442,Y,11,Z,0),U,19)="" X=1
87 Q X
Note: See TracBrowser for help on using the repository browser.