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