source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPDAPV.m@ 1078

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

initial load of WorldVistAEHR
File size: 4.4 KB
Line 
1PRCPDAPV ;WISC/RFJ-drug accountability/prime vendor ;12.15.97
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 N %,COSTCNTR,COUNT,DATA,I,LINE,PRC,PRCPFERR,PRCPFLAG,PRCPREPN,PRCPVEND,PRCSIP,SEGMENT,X,Y
5 S IOP="HOME" D ^%ZIS K IOP
6 K X S X(1)="* * * E N T E R C O N T R O L P O I N T I N F O R M A T I O N * * *" D DISPLAY^PRCPUX2(1,79,.X)
7 D ^PRCSUT Q:Y<0
8 I '$D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) K X S X(1)="ERROR - cannot find STATION ("_PRC("SITE")_") and CONTROL POINT ("_PRC("CP")_") in FUND CONTROL POINT file 420." D DISPLAY^PRCPUX2(5,75,.X) Q
9 ; special control point
10 ; removed hard set of 600000 cost center for Supply Fund w/ 149
11 I '$O(^PRC(420,PRC("SITE"),1,+PRC("CP"),2,0)) K X S X(1)="ERROR - No COST CENTERS have been entered for this CONTROL POINT ("_PRC("CP")_")." D DISPLAY^PRCPUX2(5,75,.X) Q
12 D Q:'COSTCNTR
13 . N DIC,I,X,Y
14 . S DIC("A")="Select COST CENTER: ",DIC="^PRC(420,PRC(""SITE""),1,+PRC(""CP""),2,",DIC(0)="AEMNQZ"
15 . D ^DIC I Y'>0 Q
16 . S COSTCNTR=+Y
17 I '$D(^PRCD(420.1,COSTCNTR,0)) K X S X(1)="ERROR - cannot find COST CENTER ("_COSTCNTR_") in COST CENTER file 420.1." D DISPLAY^PRCPUX2(5,75,.X) Q
18 ;
19 S PRCPREPN=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")_"-"_COSTCNTR
20 K X S X(1)="I will generate requests for: "_PRCPREPN D DISPLAY^PRCPUX2(1,79,.X)
21 ;
22 K X S X(1)="Select the PRIME VENDOR for the requests." D DISPLAY^PRCPUX2(1,79,.X)
23 S PRCPVEND=$$VENDOR^PRCPAGPV I PRCPVEND'>0 Q
24 ;
25 F D Q:$G(PRCPFLAG)
26 . N DWLC,XTKDIC,XTKERR,XTKMODE
27 . K ^TMP($J,"PRCPDAPV"),PRCPFLAG
28 . K X S X(1)="* * * U P L O A D O F P R I M E V E N D O R I N V O I C E * * *" W ! D DISPLAY^PRCPUX2(1,79,.X)
29 . S XP="ARE YOU READY TO UPLOAD THE PRIME VENDOR INVOICE",XH="Enter YES to start the upload of the prime vendor invoice, NO or ^ to exit."
30 . I $$YN^PRCPUYN(2)'=1 S PRCPFLAG=1 Q
31 . K X S X(1)="Press <ALT> 1 if your Prime Vendor script is installed as a Meta Key, otherwise press <ALT> F5 and enter ""PV"""
32 . W ! D DISPLAY^PRCPUX2(1,79,.X)
33 . X ^%ZOSF("EOFF") R X:20 X ^%ZOSF("EON") D HASH^XUSHSHP I X'="$4_\y o\Xp>RN}ab*_%," S PRCPFLAG=1
34 . I '$G(PRCPFLAG) S XTKDIC="^TMP($J,""PRCPDAPV"",",DWLC=0,XTKMODE=2 D RECEIVE^XTKERMIT
35 . I $G(PRCPFLAG) S XTKERR="PRIME VENDOR INVOICE CORRUPT" K ^TMP($J,"PRCPDAPV") H 1
36 . I $G(XTKERR)'=0 K X S X(1)="ERROR - "_XTKERR D DISPLAY^PRCPUX2(5,75,.X) Q
37 . I DWLC=0 K X S X(1)="ERROR - NO LINES RECEIVED." D DISPLAY^PRCPUX2(5,75,.X) Q
38 . W !,"OK, FINISHED WITH SUCCESSFUL UPLOAD, ",DWLC," lines received."
39 . S PRCPFLAG=1
40 I '$O(^TMP($J,"PRCPDAPV",0)) D Q Q
41 ;
42 K X S X(1)="* * * U N W R A P P I N G T H E I N V O I C E * * * " W ! D DISPLAY^PRCPUX2(1,79,.X)
43 K ^TMP($J,"PRCPDAPVS"),PRCPFLAG
44 S DATA="",LINE=1,COUNT=0 F D Q:$G(PRCPFLAG)
45 . I DATA'[$C(126) S DATA=DATA_$TR($G(^TMP($J,"PRCPDAPV",LINE,0)),"*\","^~"),LINE=LINE+1
46 . I DATA'[$C(126) S DATA=DATA_$TR($G(^TMP($J,"PRCPDAPV",LINE,0)),"*\","^~"),LINE=LINE+1
47 . I '$D(^TMP($J,"PRCPDAPV",LINE,0)) S PRCPFLAG=1
48 . F Q:DATA'["~" S SEGMENT=$P(DATA,"~"),DATA=$P(DATA,"~",2,999) D
49 . . ; remove all leading spaces
50 . . F Q:$E(SEGMENT)'=" " S SEGMENT=$E(SEGMENT,2,999)
51 . . S COUNT=COUNT+1,^TMP($J,"PRCPDAPVS",COUNT)=SEGMENT
52 W !,"OK, FINISHED UNWRAPPING THE INVOICE."
53 K ^TMP($J,"PRCPDAPV")
54 ;
55 K X S X(1)="* * * P R O C E S S I N G I N V O I C E D A T A * * *" W ! D DISPLAY^PRCPUX2(1,79,.X)
56 D PROCESS^PRCPDAP1
57 I $G(PRCPFLAG) D Q Q
58 W !,"OK, FINISHED PROCESSING INVOICE DATA.",!
59 K ^TMP($J,"PRCPDAPVS")
60 ;
61 I $G(PRCPFERR) D
62 . K X S X(1)="ERRORS HAVE BEEN FOUND AND THE REPETITIVE ITEM LISTS CANNOT BE BUILT. PLEASE RE-UPLOAD THE PRIME VENDOR INVOICE AFTER CORRECTING THE ERRORS." D DISPLAY^PRCPUX2(1,79,.X)
63 I '$G(PRCPFERR) D
64 . K X S X(1)="* * * B U I L D R E P E T I T I V E I T E M L I S T S * * *" D DISPLAY^PRCPUX2(1,79,.X)
65 . K PRCPFLAG
66 . D BUILDRIL^PRCPDAPB
67 . I $G(PRCPFLAG) D Q
68 . . K X S X(1)="THE SYSTEM HAD PROBLEMS CREATING THE REPETITIVE ITEM LISTS. PLEASE TRY AND RE-UPLOAD THE PRIME VENDOR INVOICE AGAIN LATER." D DISPLAY^PRCPUX2(1,79,.X)
69 . W !,"OK, FINISHED BUILDING THE REPETITIVE ITEM LISTS."
70 ;
71 K X S X(1)="* * * P R I N T I T E M S O N I N V O I C E * * *" W ! D DISPLAY^PRCPUX2(1,79,.X)
72 D PRINT^PRCPDAP2
73 I '$G(PRCPFERR) W !,"THE UPLOAD WAS SUCCESSFUL."
74Q K ^TMP($J,"PRCPDAPV"),^TMP($J,"PRCPDAPVS"),^TMP($J,"PRCPDAPV SET")
75 Q
Note: See TracBrowser for help on using the repository browser.