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

PRCPDAPV ;WISC/RFJ-drug accountability/prime vendor ;12.15.97

 ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 N %,COSTCNTR,COUNT,DATA,I,LINE,PRC,PRCPFERR,PRCPFLAG,PRCPREPN,PRCPVEND,PRCSIP,SEGMENT,X,Y

 S IOP="HOME" D ^%ZIS K IOP

 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)

 D ^PRCSUT Q:Y<0

 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

 ;  special control point

 ;    removed hard set of 600000 cost center for Supply Fund w/ 149

 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

 D  Q:'COSTCNTR

 .   N DIC,I,X,Y

 .   S DIC("A")="Select COST CENTER: ",DIC="^PRC(420,PRC(""SITE""),1,+PRC(""CP""),2,",DIC(0)="AEMNQZ"

 .   D ^DIC I Y'>0 Q

 .   S COSTCNTR=+Y

 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

 ;

 S PRCPREPN=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")_"-"_COSTCNTR

 K X S X(1)="I will generate requests for: "_PRCPREPN D DISPLAY^PRCPUX2(1,79,.X)

 ;

 K X S X(1)="Select the PRIME VENDOR for the requests." D DISPLAY^PRCPUX2(1,79,.X)

 S PRCPVEND=$$VENDOR^PRCPAGPV I PRCPVEND'>0 Q

 ;

 F  D  Q:$G(PRCPFLAG)

 .   N DWLC,XTKDIC,XTKERR,XTKMODE

 .   K ^TMP($J,"PRCPDAPV"),PRCPFLAG

 .   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)

 .   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."

 .   I $$YN^PRCPUYN(2)'=1 S PRCPFLAG=1 Q

 .   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"""

 .   W ! D DISPLAY^PRCPUX2(1,79,.X)

 .   X ^%ZOSF("EOFF") R X:20 X ^%ZOSF("EON") D HASH^XUSHSHP I X'="$4_\y o\Xp>RN}ab*_%," S PRCPFLAG=1

 .   I '$G(PRCPFLAG) S XTKDIC="^TMP($J,""PRCPDAPV"",",DWLC=0,XTKMODE=2 D RECEIVE^XTKERMIT

 .   I $G(PRCPFLAG) S XTKERR="PRIME VENDOR INVOICE CORRUPT" K ^TMP($J,"PRCPDAPV") H 1

 .   I $G(XTKERR)'=0 K X S X(1)="ERROR - "_XTKERR D DISPLAY^PRCPUX2(5,75,.X) Q

 .   I DWLC=0 K X S X(1)="ERROR - NO LINES RECEIVED." D DISPLAY^PRCPUX2(5,75,.X) Q

 .   W !,"OK, FINISHED WITH SUCCESSFUL UPLOAD, ",DWLC," lines received."

 .   S PRCPFLAG=1

 I '$O(^TMP($J,"PRCPDAPV",0)) D Q Q

 ;

 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)

 K ^TMP($J,"PRCPDAPVS"),PRCPFLAG

 S DATA="",LINE=1,COUNT=0 F  D  Q:$G(PRCPFLAG)

 .   I DATA'[$C(126) S DATA=DATA_$TR($G(^TMP($J,"PRCPDAPV",LINE,0)),"*\","^~"),LINE=LINE+1

 .   I DATA'[$C(126) S DATA=DATA_$TR($G(^TMP($J,"PRCPDAPV",LINE,0)),"*\","^~"),LINE=LINE+1

 .   I '$D(^TMP($J,"PRCPDAPV",LINE,0)) S PRCPFLAG=1

 .   F  Q:DATA'["~"  S SEGMENT=$P(DATA,"~"),DATA=$P(DATA,"~",2,999) D

 .   .   ;  remove all leading spaces

 .   .   F  Q:$E(SEGMENT)'=" "  S SEGMENT=$E(SEGMENT,2,999)

 .   .   S COUNT=COUNT+1,^TMP($J,"PRCPDAPVS",COUNT)=SEGMENT

 W !,"OK, FINISHED UNWRAPPING THE INVOICE."

 K ^TMP($J,"PRCPDAPV")

 ;

 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)

 D PROCESS^PRCPDAP1

 I $G(PRCPFLAG) D Q Q

 W !,"OK, FINISHED PROCESSING INVOICE DATA.",!

 K ^TMP($J,"PRCPDAPVS")

 ;

 I $G(PRCPFERR) D

 .   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)

 I '$G(PRCPFERR) D

 .   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)

 .   K PRCPFLAG

 .   D BUILDRIL^PRCPDAPB

 .   I $G(PRCPFLAG) D  Q

 .   .   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)

 .   W !,"OK, FINISHED BUILDING THE REPETITIVE ITEM LISTS."

 ;

 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)

 D PRINT^PRCPDAP2

 I '$G(PRCPFERR) W !,"THE UPLOAD WAS SUCCESSFUL."

Q K ^TMP($J,"PRCPDAPV"),^TMP($J,"PRCPDAPVS"),^TMP($J,"PRCPDAPV SET")

 Q