- 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 Mar 13, 2025@21:05:46 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
