PRCORV1 ;WISC/DJM/BGJ/AS-IFCAP VRQ REVIEW ROUTINE, CONTINUED ;2/17/22 12:13
V ;;5.1;IFCAP;**7,81,227**;Oct 20, 2000;Build 1
;Per VHA Directive 6402, this routine should not be modified.
REV ;COMPLETE REVIEW OF VENDOR ENTRY
N SPACE,VALMY,IEN,PRCOI,PRCOIN,DIC,DA,DR,DIQ,DIR,Y,X
D EN^VALM2(XQORNOD(0),"OS")
S PRCOI=0
S PRCOI=$O(VALMY(PRCOI)) G:'PRCOI REVQ
S PRCOIN=$G(^TMP("PRCORV",$J,PRCOI))
S IEN=+$P(PRCOIN,U,2)
D FULL^VALM1
W @IOF
K PRCORVP
S DIC="^PRC(440,",DA=IEN,DR=".01:55",DIQ="PRCORVP",DIQ(0)="E"
D EN^DIQ1
S $P(SPACE," ",24)=" "
W !!," Vendor Name: "_$$FIELD(IEN,.01)
W ?70,"PAGE: 1"
W !," Ordering Address: "_$$FIELD(IEN,1)
W:$$FIELD(IEN,2)]"" !,SPACE_$$FIELD(IEN,2)
S X=SPACE
S:$$FIELD(IEN,4.2)]"" X=X_$$FIELD(IEN,4.2)_", "
S:$$FIELD(IEN,4.4)]"" X=X_$$FIELD(IEN,4.4)_" "
S X=X_$S($L($$FIELD(IEN,4.6))=9:$E($$FIELD(IEN,4.6),1,5)_"-"_$E($$FIELD(IEN,4.6),6,9),1:$$FIELD(IEN,4.6))
W !,X
W !!," FMS Name: "_$$FIELD(IEN,34.5)
W !!," Payment ADDRESS: "_$$FIELD(IEN,17.3)
W !,SPACE_$$FIELD(IEN,17.4)
W:$$FIELD(IEN,17.5)]"" !,SPACE_$$FIELD(IEN,17.5)
W:$$FIELD(IEN,17.6)]"" !,SPACE_$$FIELD(IEN,17.6)
S X=SPACE
S:$$FIELD(IEN,17.7)]"" X=X_$$FIELD(IEN,17.7)_", "
S:$$FIELD(IEN,17.8)]"" X=X_$$FIELD(IEN,17.8)_" "
S X=X_$S($L($$FIELD(IEN,17.9))=9:$E($$FIELD(IEN,17.9),1,5)_"-"_$E($$FIELD(IEN,17.9),6,9),1:$$FIELD(IEN,17.9))
W !,X
W !!,"PAYMENT CONTACT PERSON: "_$$FIELD(IEN,17)
W !," PAYMENT PHONE NUMBER: "_$$FIELD(IEN,7.2)
W !
S DIR(0)="E"
D ^DIR
K DIR
W !
G:Y'=1 REVEXIT
W @IOF
W !!," VENDOR NAME: "_$$FIELD(IEN,.01)
W ?70,"PAGE: 2"
W !!," FMS VENDOR CODE: "_$$FIELD(IEN,34)
W !," ALT-ADDR-IND: "_$$FIELD(IEN,35)
W !," TAX ID/SSN: "_$$FIELD(IEN,38)
W !," SSN/TAX ID IND: "_$$FIELD(IEN,39)
W !!," NON-RECURRING/"
W !," RECURRUNG VENDOR: "_$$FIELD(IEN,36)
W !!,"1099 VENDOR INDICATOR: "_$$FIELD(IEN,41)
W !," VENDOR TYPE: "_$$FIELD(IEN,44)
W !," DUN & BRADSTREET: "_$$FIELD(IEN,18.3)
W !," UEI: "_$$FIELD(IEN,55)
W !
S DIR(0)="E"
S DIR("A")="Enter RETURN to continue"
D ^DIR
K DIR
REVEXIT S VALMBCK="R",VALMBG=1
REVQ Q
;
EDIT ;EDIT THIS VENDOR
N PRCOI,PRCOIN,IEN,DIRUT,NAME,PRCFA
D EN^VALM2(XQORNOD(0),"OS")
S PRCOI=0
S PRCOI=$O(VALMY(PRCOI)) G:'PRCOI REVQ
S PRCOIN=$G(^TMP("PRCORV",$J,PRCOI))
S IEN=+$P(PRCOIN,U,2)
D FULL^VALM1
W @IOF
S NAME=$P($G(^PRC(440,IEN,0)),U)
W:NAME]"" !!,NAME
D HILO^PRCFQ
S (DA,PRCFA("VEND"))=IEN D INFO^PRCFAC3 K PRCTMP D DOIT
G:$D(DIRUT)!(Y'=1) EDITEX
D SCREEN
L +^PRC(440,DA):5 E W !,$C(7),"Another user is editing this entry!" G EDITEX
;K ^PRC(440.3,DA) S %X="^PRC(440,DA,",%Y="^PRC(440.3,DA," D %XY^%RCR
S DIE="^PRC(440,",DR="[PRCF FMS VENEDIT1B]"
D ^DIE K DIE,DR,ORDER
L -^PRC(440,PRCFA("VEND"))
EDITEX S VALMBCK="R",VALMBG=1
; SEND VENDOR UPDATE INFORMATION TO DYNAMED **81**
I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1,$D(IEN) D ONECHK^PRCVNDR(PRCFA("VEND"))
Q
;
SEND ;SEND THIS VRQ TO AUSTIN
N PRCOI,PRCOIN,IEN
D EN^VALM2(XQORNOD(0),"OS")
S PRCOI=0
S PRCOI=$O(VALMY(PRCOI)) G:'PRCOI REVQ
S PRCOIN=$G(^TMP("PRCORV",$J,PRCOI))
S IEN=+$P(PRCOIN,U,2)
D SEND^PRCHE1(IEN)
D INIT^PRCORV
S VALMBCK="R",VALMBG=1
Q
;
DELETE ;DELETE THIS VENDOR REQUEST FROM THE LOCAL IFCAP SYSTEM
N PRCOI,PRCOIN,IEN,VRQ,COUNT
D EN^VALM2(XQORNOD(0),"OS")
S PRCOI=0
S PRCOI=$O(VALMY(PRCOI)) G:'PRCOI REVQ
S PRCOIN=$G(^TMP("PRCORV",$J,PRCOI))
S IEN=+$P(PRCOIN,U,2)
S NAME=$P($G(^PRC(440,IEN,0)),U)
S DIR("A")="Do you want to delete "_NAME_" (YES/NO)"
S DIR(0)="Y"
S DIR("B")="NO"
D ^DIR
K DIR
G:Y'=1 NODELETE
S VRQ=$O(^PRCF(422.2,"B","123-VRQ-01",0))
S COUNT=$P(^PRCF(422.2,VRQ,0),U,2),COUNT=$S(COUNT-1>0:COUNT-1,1:0),$P(^PRCF(422.2,VRQ,0),U,2)=COUNT
K ^PRC(440.3,"AD",IEN,IEN)
K ^PRC(440.3,IEN)
D INIT^PRCORV
NODELETE S VALMBCK="R",VALMBG=1
Q
;
FIELD(IEN,FIELD) ;FETCH EXTERNAL VALUE OF FIELD
;FOR RECORD 'IEN' FROM FILE 440.3
S FIELD=$G(PRCORVP(440,IEN,FIELD,"E"))
Q FIELD
;
DOIT ;FIND OUT IF USER WANTS TO EDIT VENDOR RECORD
W !
S DIR(0)="Y"
S DIR("A")="Edit the payment information on Vendor record"
S DIR("B")="YES"
S DIR("?")="Enter 'NO' or 'N' or '^' to exit this edit session."
S DIR("?",1)="Enter 'YES' or 'Y' or 'RETURN' to continue."
D ^DIR
K DIR
W !
Q
;
SCREEN ; Control screen display
I $D(IOF) W @IOF
HDR ; Write Option Header
I $D(XQY0) W IOINHI,$P(XQY0,U,2),IOINORM,!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCORV1 4594 printed Dec 13, 2024@02:12:05 Page 2
PRCORV1 ;WISC/DJM/BGJ/AS-IFCAP VRQ REVIEW ROUTINE, CONTINUED ;2/17/22 12:13
V ;;5.1;IFCAP;**7,81,227**;Oct 20, 2000;Build 1
+1 ;Per VHA Directive 6402, this routine should not be modified.
REV ;COMPLETE REVIEW OF VENDOR ENTRY
+1 NEW SPACE,VALMY,IEN,PRCOI,PRCOIN,DIC,DA,DR,DIQ,DIR,Y,X
+2 DO EN^VALM2(XQORNOD(0),"OS")
+3 SET PRCOI=0
+4 SET PRCOI=$ORDER(VALMY(PRCOI))
if 'PRCOI
GOTO REVQ
+5 SET PRCOIN=$GET(^TMP("PRCORV",$JOB,PRCOI))
+6 SET IEN=+$PIECE(PRCOIN,U,2)
+7 DO FULL^VALM1
+8 WRITE @IOF
+9 KILL PRCORVP
+10 SET DIC="^PRC(440,"
SET DA=IEN
SET DR=".01:55"
SET DIQ="PRCORVP"
SET DIQ(0)="E"
+11 DO EN^DIQ1
+12 SET $PIECE(SPACE," ",24)=" "
+13 WRITE !!," Vendor Name: "_$$FIELD(IEN,.01)
+14 WRITE ?70,"PAGE: 1"
+15 WRITE !," Ordering Address: "_$$FIELD(IEN,1)
+16 if $$FIELD(IEN,2)]""
WRITE !,SPACE_$$FIELD(IEN,2)
+17 SET X=SPACE
+18 if $$FIELD(IEN,4.2)]""
SET X=X_$$FIELD(IEN,4.2)_", "
+19 if $$FIELD(IEN,4.4)]""
SET X=X_$$FIELD(IEN,4.4)_" "
+20 SET X=X_$SELECT($LENGTH($$FIELD(IEN,4.6))=9:$EXTRACT($$FIELD(IEN,4.6),1,5)_"-"_$EXTRACT($$FIELD(IEN,4.6),6,9),1:$$FIELD(IEN,4.6))
+21 WRITE !,X
+22 WRITE !!," FMS Name: "_$$FIELD(IEN,34.5)
+23 WRITE !!," Payment ADDRESS: "_$$FIELD(IEN,17.3)
+24 WRITE !,SPACE_$$FIELD(IEN,17.4)
+25 if $$FIELD(IEN,17.5)]""
WRITE !,SPACE_$$FIELD(IEN,17.5)
+26 if $$FIELD(IEN,17.6)]""
WRITE !,SPACE_$$FIELD(IEN,17.6)
+27 SET X=SPACE
+28 if $$FIELD(IEN,17.7)]""
SET X=X_$$FIELD(IEN,17.7)_", "
+29 if $$FIELD(IEN,17.8)]""
SET X=X_$$FIELD(IEN,17.8)_" "
+30 SET X=X_$SELECT($LENGTH($$FIELD(IEN,17.9))=9:$EXTRACT($$FIELD(IEN,17.9),1,5)_"-"_$EXTRACT($$FIELD(IEN,17.9),6,9),1:$$FIELD(IEN,17.9))
+31 WRITE !,X
+32 WRITE !!,"PAYMENT CONTACT PERSON: "_$$FIELD(IEN,17)
+33 WRITE !," PAYMENT PHONE NUMBER: "_$$FIELD(IEN,7.2)
+34 WRITE !
+35 SET DIR(0)="E"
+36 DO ^DIR
+37 KILL DIR
+38 WRITE !
+39 if Y'=1
GOTO REVEXIT
+40 WRITE @IOF
+41 WRITE !!," VENDOR NAME: "_$$FIELD(IEN,.01)
+42 WRITE ?70,"PAGE: 2"
+43 WRITE !!," FMS VENDOR CODE: "_$$FIELD(IEN,34)
+44 WRITE !," ALT-ADDR-IND: "_$$FIELD(IEN,35)
+45 WRITE !," TAX ID/SSN: "_$$FIELD(IEN,38)
+46 WRITE !," SSN/TAX ID IND: "_$$FIELD(IEN,39)
+47 WRITE !!," NON-RECURRING/"
+48 WRITE !," RECURRUNG VENDOR: "_$$FIELD(IEN,36)
+49 WRITE !!,"1099 VENDOR INDICATOR: "_$$FIELD(IEN,41)
+50 WRITE !," VENDOR TYPE: "_$$FIELD(IEN,44)
+51 WRITE !," DUN & BRADSTREET: "_$$FIELD(IEN,18.3)
+52 WRITE !," UEI: "_$$FIELD(IEN,55)
+53 WRITE !
+54 SET DIR(0)="E"
+55 SET DIR("A")="Enter RETURN to continue"
+56 DO ^DIR
+57 KILL DIR
REVEXIT SET VALMBCK="R"
SET VALMBG=1
REVQ QUIT
+1 ;
EDIT ;EDIT THIS VENDOR
+1 NEW PRCOI,PRCOIN,IEN,DIRUT,NAME,PRCFA
+2 DO EN^VALM2(XQORNOD(0),"OS")
+3 SET PRCOI=0
+4 SET PRCOI=$ORDER(VALMY(PRCOI))
if 'PRCOI
GOTO REVQ
+5 SET PRCOIN=$GET(^TMP("PRCORV",$JOB,PRCOI))
+6 SET IEN=+$PIECE(PRCOIN,U,2)
+7 DO FULL^VALM1
+8 WRITE @IOF
+9 SET NAME=$PIECE($GET(^PRC(440,IEN,0)),U)
+10 if NAME]""
WRITE !!,NAME
+11 DO HILO^PRCFQ
+12 SET (DA,PRCFA("VEND"))=IEN
DO INFO^PRCFAC3
KILL PRCTMP
DO DOIT
+13 if $DATA(DIRUT)!(Y'=1)
GOTO EDITEX
+14 DO SCREEN
+15 LOCK +^PRC(440,DA):5
IF '$TEST
WRITE !,$CHAR(7),"Another user is editing this entry!"
GOTO EDITEX
+16 ;K ^PRC(440.3,DA) S %X="^PRC(440,DA,",%Y="^PRC(440.3,DA," D %XY^%RCR
+17 SET DIE="^PRC(440,"
SET DR="[PRCF FMS VENEDIT1B]"
+18 DO ^DIE
KILL DIE,DR,ORDER
+19 LOCK -^PRC(440,PRCFA("VEND"))
EDITEX SET VALMBCK="R"
SET VALMBG=1
+1 ; SEND VENDOR UPDATE INFORMATION TO DYNAMED **81**
+2 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1
IF $DATA(IEN)
DO ONECHK^PRCVNDR(PRCFA("VEND"))
+3 QUIT
+4 ;
SEND ;SEND THIS VRQ TO AUSTIN
+1 NEW PRCOI,PRCOIN,IEN
+2 DO EN^VALM2(XQORNOD(0),"OS")
+3 SET PRCOI=0
+4 SET PRCOI=$ORDER(VALMY(PRCOI))
if 'PRCOI
GOTO REVQ
+5 SET PRCOIN=$GET(^TMP("PRCORV",$JOB,PRCOI))
+6 SET IEN=+$PIECE(PRCOIN,U,2)
+7 DO SEND^PRCHE1(IEN)
+8 DO INIT^PRCORV
+9 SET VALMBCK="R"
SET VALMBG=1
+10 QUIT
+11 ;
DELETE ;DELETE THIS VENDOR REQUEST FROM THE LOCAL IFCAP SYSTEM
+1 NEW PRCOI,PRCOIN,IEN,VRQ,COUNT
+2 DO EN^VALM2(XQORNOD(0),"OS")
+3 SET PRCOI=0
+4 SET PRCOI=$ORDER(VALMY(PRCOI))
if 'PRCOI
GOTO REVQ
+5 SET PRCOIN=$GET(^TMP("PRCORV",$JOB,PRCOI))
+6 SET IEN=+$PIECE(PRCOIN,U,2)
+7 SET NAME=$PIECE($GET(^PRC(440,IEN,0)),U)
+8 SET DIR("A")="Do you want to delete "_NAME_" (YES/NO)"
+9 SET DIR(0)="Y"
+10 SET DIR("B")="NO"
+11 DO ^DIR
+12 KILL DIR
+13 if Y'=1
GOTO NODELETE
+14 SET VRQ=$ORDER(^PRCF(422.2,"B","123-VRQ-01",0))
+15 SET COUNT=$PIECE(^PRCF(422.2,VRQ,0),U,2)
SET COUNT=$SELECT(COUNT-1>0:COUNT-1,1:0)
SET $PIECE(^PRCF(422.2,VRQ,0),U,2)=COUNT
+16 KILL ^PRC(440.3,"AD",IEN,IEN)
+17 KILL ^PRC(440.3,IEN)
+18 DO INIT^PRCORV
NODELETE SET VALMBCK="R"
SET VALMBG=1
+1 QUIT
+2 ;
FIELD(IEN,FIELD) ;FETCH EXTERNAL VALUE OF FIELD
+1 ;FOR RECORD 'IEN' FROM FILE 440.3
+2 SET FIELD=$GET(PRCORVP(440,IEN,FIELD,"E"))
+3 QUIT FIELD
+4 ;
DOIT ;FIND OUT IF USER WANTS TO EDIT VENDOR RECORD
+1 WRITE !
+2 SET DIR(0)="Y"
+3 SET DIR("A")="Edit the payment information on Vendor record"
+4 SET DIR("B")="YES"
+5 SET DIR("?")="Enter 'NO' or 'N' or '^' to exit this edit session."
+6 SET DIR("?",1)="Enter 'YES' or 'Y' or 'RETURN' to continue."
+7 DO ^DIR
+8 KILL DIR
+9 WRITE !
+10 QUIT
+11 ;
SCREEN ; Control screen display
+1 IF $DATA(IOF)
WRITE @IOF
HDR ; Write Option Header
+1 IF $DATA(XQY0)
WRITE IOINHI,$PIECE(XQY0,U,2),IOINORM,!
+2 QUIT
