PRCFAC3.m

PRCFAC3 ;WISC/CTB/CLH/SJG/AS-ACCOUNTING MODULE ;3/24/17  13:12

V ;;5.1;IFCAP;**81,198**;Oct 20, 2000;Build 6

 ;Per VA Directive 6402, this routine should not be modified.

E10 ; Enter FMS Vendor Code Numbers into Vendor File

 N TAG,PRCF

 D HILO^PRCFQ

 S PRCF("X")="AS" D ^PRCFSITE Q:'%

 D SCREEN

 S PRCFA("FISCVEND")=$P($G(PRC("PARAM")),U,20)

 S TAG=$S(PRCFA("FISCVEND"):"E10B",'PRCFA("FISCVEND"):"E10A") D @TAG

OUT10 K %W,%X,%Y,D0,DA,DIC,DIE,DQ,DR,I,J,K,X,Y,DIRUT

 K PRCTMP,IOINHI,IOINLOW,IOINORM,PRCFA

 QUIT

E10A ; No adding by Fiscal/editing only

 I 'PRCFA("FISCVEND") W !!,"Only Supply may add new Vendors to the Vendor File",!,"but Fiscal may edit payment information.",!!

E10A1 W ! S DIC(0)="AENMQ",DIC=440,DIC("S")="I (+Y<950000)!$D(^XUSEC(""PRCHVEN"",DUZ))"

 D ^DIC Q:Y<0

 I Y>0 S (DA,PRCFA("VEND"))=+Y D INFO K PRCTMP D EDIT^PRCFAC31

 Q:$D(DIRUT)

 I 'Y W !!,"No further action is being taken on this Vendor.",! G E10A1

 D SCREEN

 L +^PRC(440,DA):5 E  W !,$C(7),"Another user is editing this entry!" G E10A1

 K ^PRC(440.3,DA) S %X="^PRC(440,DA,",%Y="^PRC(440.3,DA," D %XY^%RCR

 D WARN

 S DIE=DIC,DR=$S($D(^XUSEC("PRCFA VENDOR EDIT",DUZ)):"[PRCF FMS VENEDIT1B]",1:"[PRCF FMS VENEDIT1]")

 D ^DIE K DIE,DR,ORDER W ! D VEDIT^PRCHE1A(PRCFA("VEND"),PRC("SITE"))

 L -^PRC(440,PRCFA("VEND"))

 ;   SEND VENDOR UPDATE INFORMATION TO DYNAMED   **81**

 D:$$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1 ONECHK^PRCVNDR(PRCFA("VEND"))

 G E10A1

 QUIT

E10B ; Adding/editing by Fiscal

 I PRCFA("FISCVEND") W !!,"Fiscal may add new Vendors to the Vendor File.",!!

 N PRCIENB4

E10B1 W ! S DIC(0)="AENMQL",DLAYGO=440,DIC=440,DIC("S")="I (+Y<950000)!$D(^XUSEC(""PRCHVEN"",DUZ))"

 L +^PRC(440,0):30 S PRCIENB4=$P(^PRC(440,0),U,3) L -^PRC(440,0)

 D ^DIC K DLAYGO Q:Y<0

 I +Y>949999,$P(Y,U,3) L +^PRC(440,0):30 S $P(^PRC(440,0),U,3)=PRCIENB4 L -^PRC(440,0)

 I Y>0 S (DA,PRCFA("VEND"))=+Y D INFO K PRCTMP D EDIT^PRCFAC31

 Q:$D(DIRUT)

 I 'Y W !!,"No further action is being taken on this Vendor.",! G E10B1

 D SCREEN

 L +^PRC(440,DA):5 E  W !,$C(7),"Another user is editing this entry!" G E10B1

 K ^PRC(440.3,DA) S %X="^PRC(440,DA,",%Y="^PRC(440.3,DA," D %XY^%RCR

 D WARN

 S DIE=DIC,DR=$S($D(^XUSEC("PRCFA VENDOR EDIT",DUZ)):"[PRCF FMS VENEDIT2B]",1:"[PRCF FMS VENEDIT2]")

 D ^DIE K DIE,DR,ORDER W ! D VEDIT^PRCHE1A(PRCFA("VEND"),PRC("SITE"))

 L -^PRC(440,PRCFA("VEND"))

 ;   SEND VENDOR UPDATE INFORMATION TO DYNAMED   **81**

 D:$$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1 ONECHK^PRCVNDR(PRCFA("VEND"))

 G E10B1

 QUIT

 ;

E11 ;LOOK VENDOR NUMBER

 D HILO^PRCFQ

 W !,"Select Vendor Name or PO Number: " R X:$S($D(DTIME):DTIME,1:30) G:X="" OUT11

 S X1=X,DIC=440,DIC(0)="EMN" D ^DIC G:X="^" OUT11 I +Y>0 S (PRCFA("VEND"),DA)=+Y D INFO G E11

 S X=X1,DIC=442,DIC(0)="EMN" D ^DIC G:X="?" E11 G:Y<0 E11 S (PRCFA("VEND"),DA)=$P($G(^PRC(442,+Y,1)),U,1) I DA="" W !!?25,$C(7),"No Vendor for this obligation number.",! G E11

 W !,$P(^PRC(440,PRCFA("VEND"),0),"^") D INFO G E11

OUT11 K %,%W,%Y,DA,DIC,I,X,X1,Y

 K PRCTMP,PRCFA,IOINHI,IOINLO,IONORM

 QUIT

 ;

E12 ;;INQUIRE TO CODE SHEET ERROR MESSAGE

 S DIC=421.3,DIC(0)="AEMNQ" D ^DIC I Y>0 S DA=+Y,DR=1 D EN^DIQ G E12

 K %,%Y,A,D0,D1,DA,DIC,DIW,DIWF,DIWL,DIWR,DIWT,DL,DN,DR,DX,I,J,K,S,X,Y Q

E13 ;ADD/EDIT CODE SHEET ERROR MESSAGE

 S DIC="^PRCF(421.3,",DIC(0)="AEMNLQ",DLAYGO=421.3 D ^DIC K DLAYGO I Y>0 S DIE=DIC,DA=+Y,DR=1 D ^DIE W ! G E13

 K %,%DT,D0,DA,DIC,DIE,DQ,DR,DWLW,I,J,X,X1,Y Q

E14 ;INQUIRE TO TRANSMISSION RECORD

 S:'$D(PRCFASYS) PRCFASYS="FEEFENIRSCLI"

 S PRCFASYS=PRCFASYS_"RR"

 S DIC=421.2,DIC(0)="AMENQ",DIC("S")="I PRCFASYS[$P(^(0),""-"",2)" D ^DIC I Y>0 S DA=+Y,DR="0;1" D EN^DIQ G E14

 K %,A,D0,DA,DIC,DL,DR,DRX,DX,S,X,Y Q

INFO ; Get/Print Vendor Payment Information

 I '$D(^PRC(440,PRCFA("VEND"),7)) W !!,$C(7),"No payment information in Vendor File.",!! Q

 S DIR(0)="Y",DIR("A")="Review current payment information on this Vendor",DIR("B")="YES" W ! D ^DIR K DIR

 I 'Y!($D(DIRUT)) Q

 D GET^PRCFAC31(PRCFA("VEND")),DISPLAY^PRCFAC31(PRCFA("VEND"))

 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

WARN ;WARNING IF PENDING VRQ

 I $P($G(^PRC(440,DA,3)),U,12)="P" W !!,"There is a FMS Vendor Request pending for this vendor.",!,"Any changes you make now may be overwritten when the Vendor",!,"Update is received.",!!

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCFAC3   4413     printed  Mar 13, 2025@21:06:41                                                                                                                                                                                                     Page 2

PRCFAC3   ;WISC/CTB/CLH/SJG/AS-ACCOUNTING MODULE ;3/24/17  13:12

V         ;;5.1;IFCAP;**81,198**;Oct 20, 2000;Build 6

 +1       ;Per VA Directive 6402, this routine should not be modified.

E10       ; Enter FMS Vendor Code Numbers into Vendor File

 +1        NEW TAG,PRCF

 +2        DO HILO^PRCFQ

 +3        SET PRCF("X")="AS"

           DO ^PRCFSITE

           if '%

               QUIT 

 +4        DO SCREEN

 +5        SET PRCFA("FISCVEND")=$PIECE($GET(PRC("PARAM")),U,20)

 +6        SET TAG=$SELECT(PRCFA("FISCVEND"):"E10B",'PRCFA("FISCVEND"):"E10A")

           DO @TAG

OUT10      KILL %W,%X,%Y,D0,DA,DIC,DIE,DQ,DR,I,J,K,X,Y,DIRUT

 +1        KILL PRCTMP,IOINHI,IOINLOW,IOINORM,PRCFA

 +2        QUIT 

E10A      ; No adding by Fiscal/editing only

 +1        IF 'PRCFA("FISCVEND")

               WRITE !!,"Only Supply may add new Vendors to the Vendor File",!,"but Fiscal may edit payment information.",!!

E10A1      WRITE !

           SET DIC(0)="AENMQ"

           SET DIC=440

           SET DIC("S")="I (+Y<950000)!$D(^XUSEC(""PRCHVEN"",DUZ))"

 +1        DO ^DIC

           if Y<0

               QUIT 

 +2        IF Y>0

               SET (DA,PRCFA("VEND"))=+Y

               DO INFO

               KILL PRCTMP

               DO EDIT^PRCFAC31

 +3        if $DATA(DIRUT)

               QUIT 

 +4        IF 'Y

               WRITE !!,"No further action is being taken on this Vendor.",!

               GOTO E10A1

 +5        DO SCREEN

 +6        LOCK +^PRC(440,DA):5

          IF '$TEST

               WRITE !,$CHAR(7),"Another user is editing this entry!"

               GOTO E10A1

 +7        KILL ^PRC(440.3,DA)

           SET %X="^PRC(440,DA,"

           SET %Y="^PRC(440.3,DA,"

           DO %XY^%RCR

 +8        DO WARN

 +9        SET DIE=DIC

           SET DR=$SELECT($DATA(^XUSEC("PRCFA VENDOR EDIT",DUZ)):"[PRCF FMS VENEDIT1B]",1:"[PRCF FMS VENEDIT1]")

 +10       DO ^DIE

           KILL DIE,DR,ORDER

           WRITE !

           DO VEDIT^PRCHE1A(PRCFA("VEND"),PRC("SITE"))

 +11       LOCK -^PRC(440,PRCFA("VEND"))

 +12      ;   SEND VENDOR UPDATE INFORMATION TO DYNAMED   **81**

 +13       if $$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1

               DO ONECHK^PRCVNDR(PRCFA("VEND"))

 +14       GOTO E10A1

 +15       QUIT 

E10B      ; Adding/editing by Fiscal

 +1        IF PRCFA("FISCVEND")

               WRITE !!,"Fiscal may add new Vendors to the Vendor File.",!!

 +2        NEW PRCIENB4

E10B1      WRITE !

           SET DIC(0)="AENMQL"

           SET DLAYGO=440

           SET DIC=440

           SET DIC("S")="I (+Y<950000)!$D(^XUSEC(""PRCHVEN"",DUZ))"

 +1        LOCK +^PRC(440,0):30

           SET PRCIENB4=$PIECE(^PRC(440,0),U,3)

           LOCK -^PRC(440,0)

 +2        DO ^DIC

           KILL DLAYGO

           if Y<0

               QUIT 

 +3        IF +Y>949999

               IF $PIECE(Y,U,3)

                   LOCK +^PRC(440,0):30

                   SET $PIECE(^PRC(440,0),U,3)=PRCIENB4

                   LOCK -^PRC(440,0)

 +4        IF Y>0

               SET (DA,PRCFA("VEND"))=+Y

               DO INFO

               KILL PRCTMP

               DO EDIT^PRCFAC31

 +5        if $DATA(DIRUT)

               QUIT 

 +6        IF 'Y

               WRITE !!,"No further action is being taken on this Vendor.",!

               GOTO E10B1

 +7        DO SCREEN

 +8        LOCK +^PRC(440,DA):5

          IF '$TEST

               WRITE !,$CHAR(7),"Another user is editing this entry!"

               GOTO E10B1

 +9        KILL ^PRC(440.3,DA)

           SET %X="^PRC(440,DA,"

           SET %Y="^PRC(440.3,DA,"

           DO %XY^%RCR

 +10       DO WARN

 +11       SET DIE=DIC

           SET DR=$SELECT($DATA(^XUSEC("PRCFA VENDOR EDIT",DUZ)):"[PRCF FMS VENEDIT2B]",1:"[PRCF FMS VENEDIT2]")

 +12       DO ^DIE

           KILL DIE,DR,ORDER

           WRITE !

           DO VEDIT^PRCHE1A(PRCFA("VEND"),PRC("SITE"))

 +13       LOCK -^PRC(440,PRCFA("VEND"))

 +14      ;   SEND VENDOR UPDATE INFORMATION TO DYNAMED   **81**

 +15       if $$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1

               DO ONECHK^PRCVNDR(PRCFA("VEND"))

 +16       GOTO E10B1

 +17       QUIT 

 +18      ;

E11       ;LOOK VENDOR NUMBER

 +1        DO HILO^PRCFQ

 +2        WRITE !,"Select Vendor Name or PO Number: "

           READ X:$SELECT($DATA(DTIME):DTIME,1:30)

           if X=""

               GOTO OUT11

 +3        SET X1=X

           SET DIC=440

           SET DIC(0)="EMN"

           DO ^DIC

           if X="^"

               GOTO OUT11

           IF +Y>0

               SET (PRCFA("VEND"),DA)=+Y

               DO INFO

               GOTO E11

 +4        SET X=X1

           SET DIC=442

           SET DIC(0)="EMN"

           DO ^DIC

           if X="?"

               GOTO E11

           if Y<0

               GOTO E11

           SET (PRCFA("VEND"),DA)=$PIECE($GET(^PRC(442,+Y,1)),U,1)

           IF DA=""

               WRITE !!?25,$CHAR(7),"No Vendor for this obligation number.",!

               GOTO E11

 +5        WRITE !,$PIECE(^PRC(440,PRCFA("VEND"),0),"^")

           DO INFO

           GOTO E11

OUT11      KILL %,%W,%Y,DA,DIC,I,X,X1,Y

 +1        KILL PRCTMP,PRCFA,IOINHI,IOINLO,IONORM

 +2        QUIT 

 +3       ;

E12       ;;INQUIRE TO CODE SHEET ERROR MESSAGE

 +1        SET DIC=421.3

           SET DIC(0)="AEMNQ"

           DO ^DIC

           IF Y>0

               SET DA=+Y

               SET DR=1

               DO EN^DIQ

               GOTO E12

 +2        KILL %,%Y,A,D0,D1,DA,DIC,DIW,DIWF,DIWL,DIWR,DIWT,DL,DN,DR,DX,I,J,K,S,X,Y

           QUIT 

E13       ;ADD/EDIT CODE SHEET ERROR MESSAGE

 +1        SET DIC="^PRCF(421.3,"

           SET DIC(0)="AEMNLQ"

           SET DLAYGO=421.3

           DO ^DIC

           KILL DLAYGO

           IF Y>0

               SET DIE=DIC

               SET DA=+Y

               SET DR=1

               DO ^DIE

               WRITE !

               GOTO E13

 +2        KILL %,%DT,D0,DA,DIC,DIE,DQ,DR,DWLW,I,J,X,X1,Y

           QUIT 

E14       ;INQUIRE TO TRANSMISSION RECORD

 +1        if '$DATA(PRCFASYS)

               SET PRCFASYS="FEEFENIRSCLI"

 +2        SET PRCFASYS=PRCFASYS_"RR"

 +3        SET DIC=421.2

           SET DIC(0)="AMENQ"

           SET DIC("S")="I PRCFASYS[$P(^(0),""-"",2)"

           DO ^DIC

           IF Y>0

               SET DA=+Y

               SET DR="0;1"

               DO EN^DIQ

               GOTO E14

 +4        KILL %,A,D0,DA,DIC,DL,DR,DRX,DX,S,X,Y

           QUIT 

INFO      ; Get/Print Vendor Payment Information

 +1        IF '$DATA(^PRC(440,PRCFA("VEND"),7))

               WRITE !!,$CHAR(7),"No payment information in Vendor File.",!!

               QUIT 

 +2        SET DIR(0)="Y"

           SET DIR("A")="Review current payment information on this Vendor"

           SET DIR("B")="YES"

           WRITE !

           DO ^DIR

           KILL DIR

 +3        IF 'Y!($DATA(DIRUT))

               QUIT 

 +4        DO GET^PRCFAC31(PRCFA("VEND"))

           DO DISPLAY^PRCFAC31(PRCFA("VEND"))

 +5        QUIT 

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 

WARN      ;WARNING IF PENDING VRQ

 +1        IF $PIECE($GET(^PRC(440,DA,3)),U,12)="P"

               WRITE !!,"There is a FMS Vendor Request pending for this vendor.",!,"Any changes you make now may be overwritten when the Vendor",!,"Update is received.",!!

 +2        QUIT