76 lines
4.4 KiB
Mathematica
76 lines
4.4 KiB
Mathematica
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
|