- 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 Feb 18, 2025@23:38:58 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