PRCPAGPV ;WISC/RFJ-autogen primary or whse order (select vendor) ;11 Dec 92
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
GETVEND ; select vendors
; returns tmp global of vendors selected or de-selected;
; vendall if all vendors selected (can be used in combination
; with the tmp global); $g(prcpexit) to exit autogen.
N %,PRCPFLAG,V,VENDOR,VENDORNM,X,Y
K PRCPEXIT,VENDALL
D ALLVEND I $G(PRCPFLAG) S PRCPEXIT=1 Q
F D I $G(PRCPFLAG) Q
. I $O(^TMP($J,"PRCPAG","VY",0))!($G(VENDALL)) D
. . W !!," Currently selected vendors:",!," "
. . I $G(VENDALL) W "<< ALL VENDORS >>"
. . E S V=0 F S V=$O(^TMP($J,"PRCPAG","VY",V)) Q:'V S %=$E(^(V),1,20),%=%_$E(" ",$L(%),20) W:$X>70 !," " W %," "
. . W !," You can DE-select one of the above vendors by reselecting it."
. I $O(^TMP($J,"PRCPAG","VN",0)) D
. . W !!," Currently DE-selected vendors:",!," "
. . S V=0 F S V=$O(^TMP($J,"PRCPAG","VN",V)) Q:'V S %=$E(^(V),1,20),%=%_$E(" ",$L(%),20) W:$X>70 !," " W %," "
. . W !," You can RE-select one of the above vendors by reselecting it."
. W !!,"Select the name of the vendor supplying this primary, '^' to exit."
. S VENDOR=$$VENDOR I VENDOR<0 S (PRCPFLAG,PRCPEXIT)=1 Q
. S VENDORNM=$P($G(^PRC(440,VENDOR,0)),"^")
. I VENDOR=0,'$O(^TMP($J,"PRCPAG","VY",0)),'$G(VENDALL) D ALLVEND S:$G(PRCPFLAG) PRCPEXIT=1 Q
. I VENDOR=0 S PRCPFLAG=1 Q
. I $G(VENDALL),'$D(^TMP($J,"PRCPAG","VN",VENDOR)) K ^TMP($J,"PRCPAG","VY",VENDOR) S ^TMP($J,"PRCPAG","VN",VENDOR)=VENDORNM W !?10,"DE-selected !" Q
. I $D(^TMP($J,"PRCPAG","VY",VENDOR)) K ^TMP($J,"PRCPAG","VY",VENDOR) S ^TMP($J,"PRCPAG","VN",VENDOR)=VENDORNM W !?10,"DE-selected !" Q
. I $D(^TMP($J,"PRCPAG","VN",VENDOR)) K ^(VENDOR) S ^TMP($J,"PRCPAG","VY",VENDOR)=VENDORNM W !?10,"RE-selected !" Q
. S ^TMP($J,"PRCPAG","VY",VENDOR)=VENDORNM W !?10,"selected !"
I $G(PRCPEXIT) Q
I $G(VENDALL) K ^TMP($J,"PRCPAG","VY")
I '$G(VENDALL),'$O(^TMP($J,"PRCPAG","VY",0)) W !!,"NO VENDORS SELECTED." S PRCPEXIT=1 Q
Q
;
;
VENDOR() ; select vendor
N DIC,X,Y
S DIC="^PRC(440,",DIC("S")="I '$P($G(^(10)),U,5)",DIC(0)="QEAM",PRCPPRIV=1 D ^DIC K PRCPPRIV,DIC
Q $S($G(X)["^":-1,Y<0:0,1:+Y)
;
;
ALLVEND ; select all vendors
K VENDALL,PRCPFLAG
S XP="Do you want to select ALL vendors",XH="Enter 'YES' to auto-generate for ALL vendors,",XH(1)="enter 'NO' to auto-generate selectable vendors, or '^' to exit."
W ! S %=$$YN^PRCPUYN(1)
I %=2 Q
I %=1 S VENDALL=1 Q
S PRCPFLAG=1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPAGPV 2648 printed Nov 22, 2024@17:22:40 Page 2
PRCPAGPV ;WISC/RFJ-autogen primary or whse order (select vendor) ;11 Dec 92
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
GETVEND ; select vendors
+1 ; returns tmp global of vendors selected or de-selected;
+2 ; vendall if all vendors selected (can be used in combination
+3 ; with the tmp global); $g(prcpexit) to exit autogen.
+4 NEW %,PRCPFLAG,V,VENDOR,VENDORNM,X,Y
+5 KILL PRCPEXIT,VENDALL
+6 DO ALLVEND
IF $GET(PRCPFLAG)
SET PRCPEXIT=1
QUIT
+7 FOR
Begin DoDot:1
+8 IF $ORDER(^TMP($JOB,"PRCPAG","VY",0))!($GET(VENDALL))
Begin DoDot:2
+9 WRITE !!," Currently selected vendors:",!," "
+10 IF $GET(VENDALL)
WRITE "<< ALL VENDORS >>"
+11 IF '$TEST
SET V=0
FOR
SET V=$ORDER(^TMP($JOB,"PRCPAG","VY",V))
if 'V
QUIT
SET %=$EXTRACT(^(V),1,20)
SET %=%_$EXTRACT(" ",$LENGTH(%),20)
if $X>70
WRITE !," "
WRITE %," "
+12 WRITE !," You can DE-select one of the above vendors by reselecting it."
End DoDot:2
+13 IF $ORDER(^TMP($JOB,"PRCPAG","VN",0))
Begin DoDot:2
+14 WRITE !!," Currently DE-selected vendors:",!," "
+15 SET V=0
FOR
SET V=$ORDER(^TMP($JOB,"PRCPAG","VN",V))
if 'V
QUIT
SET %=$EXTRACT(^(V),1,20)
SET %=%_$EXTRACT(" ",$LENGTH(%),20)
if $X>70
WRITE !," "
WRITE %," "
+16 WRITE !," You can RE-select one of the above vendors by reselecting it."
End DoDot:2
+17 WRITE !!,"Select the name of the vendor supplying this primary, '^' to exit."
+18 SET VENDOR=$$VENDOR
IF VENDOR<0
SET (PRCPFLAG,PRCPEXIT)=1
QUIT
+19 SET VENDORNM=$PIECE($GET(^PRC(440,VENDOR,0)),"^")
+20 IF VENDOR=0
IF '$ORDER(^TMP($JOB,"PRCPAG","VY",0))
IF '$GET(VENDALL)
DO ALLVEND
if $GET(PRCPFLAG)
SET PRCPEXIT=1
QUIT
+21 IF VENDOR=0
SET PRCPFLAG=1
QUIT
+22 IF $GET(VENDALL)
IF '$DATA(^TMP($JOB,"PRCPAG","VN",VENDOR))
KILL ^TMP($JOB,"PRCPAG","VY",VENDOR)
SET ^TMP($JOB,"PRCPAG","VN",VENDOR)=VENDORNM
WRITE !?10,"DE-selected !"
QUIT
+23 IF $DATA(^TMP($JOB,"PRCPAG","VY",VENDOR))
KILL ^TMP($JOB,"PRCPAG","VY",VENDOR)
SET ^TMP($JOB,"PRCPAG","VN",VENDOR)=VENDORNM
WRITE !?10,"DE-selected !"
QUIT
+24 IF $DATA(^TMP($JOB,"PRCPAG","VN",VENDOR))
KILL ^(VENDOR)
SET ^TMP($JOB,"PRCPAG","VY",VENDOR)=VENDORNM
WRITE !?10,"RE-selected !"
QUIT
+25 SET ^TMP($JOB,"PRCPAG","VY",VENDOR)=VENDORNM
WRITE !?10,"selected !"
End DoDot:1
IF $GET(PRCPFLAG)
QUIT
+26 IF $GET(PRCPEXIT)
QUIT
+27 IF $GET(VENDALL)
KILL ^TMP($JOB,"PRCPAG","VY")
+28 IF '$GET(VENDALL)
IF '$ORDER(^TMP($JOB,"PRCPAG","VY",0))
WRITE !!,"NO VENDORS SELECTED."
SET PRCPEXIT=1
QUIT
+29 QUIT
+30 ;
+31 ;
VENDOR() ; select vendor
+1 NEW DIC,X,Y
+2 SET DIC="^PRC(440,"
SET DIC("S")="I '$P($G(^(10)),U,5)"
SET DIC(0)="QEAM"
SET PRCPPRIV=1
DO ^DIC
KILL PRCPPRIV,DIC
+3 QUIT $SELECT($GET(X)["^":-1,Y<0:0,1:+Y)
+4 ;
+5 ;
ALLVEND ; select all vendors
+1 KILL VENDALL,PRCPFLAG
+2 SET XP="Do you want to select ALL vendors"
SET XH="Enter 'YES' to auto-generate for ALL vendors,"
SET XH(1)="enter 'NO' to auto-generate selectable vendors, or '^' to exit."
+3 WRITE !
SET %=$$YN^PRCPUYN(1)
+4 IF %=2
QUIT
+5 IF %=1
SET VENDALL=1
QUIT
+6 SET PRCPFLAG=1
QUIT
