- 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 Feb 18, 2025@23:39:51 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
