PRCBVE ;WISC@ALTOONA/CLH-ADD/EDIT CALM VENDOR FILE ;9-21-89/09:27
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;MUST PASS VARIABLE PRCB("VEN") WHICH IS INTERNAL VENDOR NUMBER
;PRC VARIABLES MUST BE SET IE. PRC("SITE")
GN ;GET TEMP NUM
D WAIT^PRCFYN S DIC="^PRCF(421.6,",DLAYGO=421.6,DIC(0)="XOLM",X=PRC("SITE")_"-"_^%ZOSF("VOL")_"-"_$J,PRCBT=0
S:'$D(COUNT) COUNT=0 D ^DIC Q:+Y<0 I +$P(Y,U,3)'=1 S COUNT=COUNT+1 Q:COUNT=3 S DIK=DIC,DA=+Y D ^DIK K DIK G GN
S PRCB("TDA")=+Y,PRCBT=1
Q
EN ;ADD VENDOR
I $D(^PRC(440,PRCB("VEN"),7)) S PRCBE=1,%A="Do you want to review the current information on this vendor",%B="",%=2 D ^PRCFYN D:%'=2 REVO
D GN S DIE=DIC,DA=PRCB("TDA"),DR="[PRCB VENDOR EDIT]"
ENV D ^DIE D REVN S %A="Is this data correct",%B="",%=1 D ^PRCFYN I %'=1 S %A="Re-edit data",%B="",%=1 D ^PRCFYN G:%=1 ENV
I '$D(^PRC(440,PRCB("VEN"),7)) S %A(1)="This vendor does not appear to have been established in CALM Vendor File",%A(2)="Do you want to establish them at this time",%B="",%=1 D ^PRCFYN G:%=1 ADVEN G SET
I $P(^PRC(440,PRCB("VEN"),7),U,10)="" S %A(1)="This vendor does not appear to have a CALM ID Number",%A(2)="Do you want to establish them to the CALM Vendor File",%B="",%=1 D ^PRCFYN G:%=1 ADVEN G SET
I $D(PRCBE) S %A="Do you want to update the CALM vendor file at this time",%B="",%=1 D ^PRCFYN G:%'=1 SET
;THIS AREA FOR UPDATING EXSITING VENDOR INFO IN CALM
ADVEN ;AREA TO SET UP MSG FOR AUSTIN TO ESTABLISH NEW VENDOR
W !!,"Twix will be sent to establish vendor: ",$P(^PRC(440,PRCB("VEN"),0),U)," in the CALM Vendor File."
SET ;MOVE TEMP INFO FROM 421.6 TO 440
W !!,"I'm going to update the your Vendor File..."
I '$D(^PRCF(421.6,PRCB("TDA"),3)) G OUT
I '$D(^PRC(440,PRCB("VEN"),7)) S OR="",$P(OR,U,1,11)=""
E S OR=$P(^PRC(440,PRCB("VEN"),7),U,1,99)
S NR=$P(^PRCF(421.6,PRCB("TDA"),3),U,1,99)
;I $P(NR,U,3)
S ^PRC(440,PRCB("VEN"),7)=$P(NR,U,12)_U_$P(NR,U,11)_U_$P(NR,U,3,9)
W !!,"Finished. Hold on while I do some clean up...."
OUT I $D(PRCB("TDA")) S DIK="^PRCF(421.6,",DA=PRCB("TDA") D ^DIK
K DIK,DIC,DIE,PRCB("TDA"),DA,X,COUNT,PRCBT,DLAYGO,%,REC,REC1,TEMP,TEMP1
Q
REVO ;REVIEW OLD VENDOR INFO
I '$D(^PRC(440,PRCB("VEN"),0)) W !!,$C(7),"** No Vendor Information available **" Q
S REC=^PRC(440,PRCB("VEN"),0) I '$D(^PRC(440,PRCB("VEN"),7)) S REC1="",$P(REC1,U,1,11)=""
E S REC1=^PRC(440,PRCB("VEN"),7)
I $D(IOF) W @IOF
W !!?5,"Vendor Name: ",$P(REC,U,1),?48,"Vendor Number: ",PRCB("VEN")
W !!!?5,"Payment Information: "
W !!?19,"Calm ID Number: " I $P(REC1,U,10)'="" W $P(REC1,U,10)
W !?19,"Stub Name: " I $P(REC1,U,11)'="" W ?35,$P(REC1,U,11)
W !?19,"Address: " I $P(REC1,U,3)'="" W ?35,$P(REC1,U,3)
I $P(REC1,U,4)'="" W !?35,$P(REC1,U,4)
I $P(REC1,U,5)'="" W !?35,$P(REC1,U,5)
I $P(REC1,U,6)'="" W !?35,$P(REC1,U,6)
I $P(REC1,U,7)'="" W !?35,$P(REC1,U,7)_", ",$P(^DIC(5,$P(REC1,U,8),0),U)_" ",$P(REC1,U,9)
W !!?19,"Phone Number: " I $P(REC1,U,2)'="" W ?35,$P(REC1,U,2)
Q
REVN ;REVIEW NEW VENDOR INFO
I '$D(^PRCF(421.6,PRCB("TDA"),3)) W !,$C(7)," - No Data Entered - " Q
E S TEMP1=^PRCF(421.6,PRCB("TDA"),3)
I $D(IOF) W @IOF
W !!?5,"Vendor Name: ",$P(^PRC(440,PRCB("VEN"),0),U)
W !!!?5,"Payment Information: "
W !!?19,"Calm ID Number: " I $P(TEMP1,U,1)'="" W $P(TEMP1,U,1)
W !?19,"Calm Stub Name: " I $P(TEMP1,U,10)'="" W ?35,$P(TEMP1,U,10)
W !?19,"Address: " I $P(TEMP1,U,3)'="" W ?35,$P(TEMP1,U,3)
I $P(TEMP1,U,4)'="" W !?35,$P(TEMP1,U,4)
I $P(TEMP1,U,5)'="" W !?35,$P(TEMP1,U,5)
I $P(TEMP1,U,6)'="" W !?35,$P(TEMP1,U,6)
I $P(TEMP1,U,7)'="" W !?35,$P(TEMP1,U,7)_", ",$P(TEMP1,U,8)_" ",$P(TEMP1,U,9)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCBVE 3697 printed Apr 09, 2024@21:16:24 Page 2
PRCBVE ;WISC@ALTOONA/CLH-ADD/EDIT CALM VENDOR FILE ;9-21-89/09:27
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;MUST PASS VARIABLE PRCB("VEN") WHICH IS INTERNAL VENDOR NUMBER
+3 ;PRC VARIABLES MUST BE SET IE. PRC("SITE")
GN ;GET TEMP NUM
+1 DO WAIT^PRCFYN
SET DIC="^PRCF(421.6,"
SET DLAYGO=421.6
SET DIC(0)="XOLM"
SET X=PRC("SITE")_"-"_^%ZOSF("VOL")_"-"_$JOB
SET PRCBT=0
+2 if '$DATA(COUNT)
SET COUNT=0
DO ^DIC
if +Y<0
QUIT
IF +$PIECE(Y,U,3)'=1
SET COUNT=COUNT+1
if COUNT=3
QUIT
SET DIK=DIC
SET DA=+Y
DO ^DIK
KILL DIK
GOTO GN
+3 SET PRCB("TDA")=+Y
SET PRCBT=1
+4 QUIT
EN ;ADD VENDOR
+1 IF $DATA(^PRC(440,PRCB("VEN"),7))
SET PRCBE=1
SET %A="Do you want to review the current information on this vendor"
SET %B=""
SET %=2
DO ^PRCFYN
if %'=2
DO REVO
+2 DO GN
SET DIE=DIC
SET DA=PRCB("TDA")
SET DR="[PRCB VENDOR EDIT]"
ENV DO ^DIE
DO REVN
SET %A="Is this data correct"
SET %B=""
SET %=1
DO ^PRCFYN
IF %'=1
SET %A="Re-edit data"
SET %B=""
SET %=1
DO ^PRCFYN
if %=1
GOTO ENV
+1 IF '$DATA(^PRC(440,PRCB("VEN"),7))
SET %A(1)="This vendor does not appear to have been established in CALM Vendor File"
SET %A(2)="Do you want to establish them at this time"
SET %B=""
SET %=1
DO ^PRCFYN
if %=1
GOTO ADVEN
GOTO SET
+2 IF $PIECE(^PRC(440,PRCB("VEN"),7),U,10)=""
SET %A(1)="This vendor does not appear to have a CALM ID Number"
SET %A(2)="Do you want to establish them to the CALM Vendor File"
SET %B=""
SET %=1
DO ^PRCFYN
if %=1
GOTO ADVEN
GOTO SET
+3 IF $DATA(PRCBE)
SET %A="Do you want to update the CALM vendor file at this time"
SET %B=""
SET %=1
DO ^PRCFYN
if %'=1
GOTO SET
+4 ;THIS AREA FOR UPDATING EXSITING VENDOR INFO IN CALM
ADVEN ;AREA TO SET UP MSG FOR AUSTIN TO ESTABLISH NEW VENDOR
+1 WRITE !!,"Twix will be sent to establish vendor: ",$PIECE(^PRC(440,PRCB("VEN"),0),U)," in the CALM Vendor File."
SET ;MOVE TEMP INFO FROM 421.6 TO 440
+1 WRITE !!,"I'm going to update the your Vendor File..."
+2 IF '$DATA(^PRCF(421.6,PRCB("TDA"),3))
GOTO OUT
+3 IF '$DATA(^PRC(440,PRCB("VEN"),7))
SET OR=""
SET $PIECE(OR,U,1,11)=""
+4 IF '$TEST
SET OR=$PIECE(^PRC(440,PRCB("VEN"),7),U,1,99)
+5 SET NR=$PIECE(^PRCF(421.6,PRCB("TDA"),3),U,1,99)
+6 ;I $P(NR,U,3)
+7 SET ^PRC(440,PRCB("VEN"),7)=$PIECE(NR,U,12)_U_$PIECE(NR,U,11)_U_$PIECE(NR,U,3,9)
+8 WRITE !!,"Finished. Hold on while I do some clean up...."
OUT IF $DATA(PRCB("TDA"))
SET DIK="^PRCF(421.6,"
SET DA=PRCB("TDA")
DO ^DIK
+1 KILL DIK,DIC,DIE,PRCB("TDA"),DA,X,COUNT,PRCBT,DLAYGO,%,REC,REC1,TEMP,TEMP1
+2 QUIT
REVO ;REVIEW OLD VENDOR INFO
+1 IF '$DATA(^PRC(440,PRCB("VEN"),0))
WRITE !!,$CHAR(7),"** No Vendor Information available **"
QUIT
+2 SET REC=^PRC(440,PRCB("VEN"),0)
IF '$DATA(^PRC(440,PRCB("VEN"),7))
SET REC1=""
SET $PIECE(REC1,U,1,11)=""
+3 IF '$TEST
SET REC1=^PRC(440,PRCB("VEN"),7)
+4 IF $DATA(IOF)
WRITE @IOF
+5 WRITE !!?5,"Vendor Name: ",$PIECE(REC,U,1),?48,"Vendor Number: ",PRCB("VEN")
+6 WRITE !!!?5,"Payment Information: "
+7 WRITE !!?19,"Calm ID Number: "
IF $PIECE(REC1,U,10)'=""
WRITE $PIECE(REC1,U,10)
+8 WRITE !?19,"Stub Name: "
IF $PIECE(REC1,U,11)'=""
WRITE ?35,$PIECE(REC1,U,11)
+9 WRITE !?19,"Address: "
IF $PIECE(REC1,U,3)'=""
WRITE ?35,$PIECE(REC1,U,3)
+10 IF $PIECE(REC1,U,4)'=""
WRITE !?35,$PIECE(REC1,U,4)
+11 IF $PIECE(REC1,U,5)'=""
WRITE !?35,$PIECE(REC1,U,5)
+12 IF $PIECE(REC1,U,6)'=""
WRITE !?35,$PIECE(REC1,U,6)
+13 IF $PIECE(REC1,U,7)'=""
WRITE !?35,$PIECE(REC1,U,7)_", ",$PIECE(^DIC(5,$PIECE(REC1,U,8),0),U)_" ",$PIECE(REC1,U,9)
+14 WRITE !!?19,"Phone Number: "
IF $PIECE(REC1,U,2)'=""
WRITE ?35,$PIECE(REC1,U,2)
+15 QUIT
REVN ;REVIEW NEW VENDOR INFO
+1 IF '$DATA(^PRCF(421.6,PRCB("TDA"),3))
WRITE !,$CHAR(7)," - No Data Entered - "
QUIT
+2 IF '$TEST
SET TEMP1=^PRCF(421.6,PRCB("TDA"),3)
+3 IF $DATA(IOF)
WRITE @IOF
+4 WRITE !!?5,"Vendor Name: ",$PIECE(^PRC(440,PRCB("VEN"),0),U)
+5 WRITE !!!?5,"Payment Information: "
+6 WRITE !!?19,"Calm ID Number: "
IF $PIECE(TEMP1,U,1)'=""
WRITE $PIECE(TEMP1,U,1)
+7 WRITE !?19,"Calm Stub Name: "
IF $PIECE(TEMP1,U,10)'=""
WRITE ?35,$PIECE(TEMP1,U,10)
+8 WRITE !?19,"Address: "
IF $PIECE(TEMP1,U,3)'=""
WRITE ?35,$PIECE(TEMP1,U,3)
+9 IF $PIECE(TEMP1,U,4)'=""
WRITE !?35,$PIECE(TEMP1,U,4)
+10 IF $PIECE(TEMP1,U,5)'=""
WRITE !?35,$PIECE(TEMP1,U,5)
+11 IF $PIECE(TEMP1,U,6)'=""
WRITE !?35,$PIECE(TEMP1,U,6)
+12 IF $PIECE(TEMP1,U,7)'=""
WRITE !?35,$PIECE(TEMP1,U,7)_", ",$PIECE(TEMP1,U,8)_" ",$PIECE(TEMP1,U,9)
+13 QUIT
