PRCPURS3 ;WISC/RFJ-select distribution points ;24 May 93
V ;;5.1;IFCAP;**1,108**;Oct 20, 2000;Build 10
;Per VHA Directive 2004-038, this routine should not be modified.
Q
;
;
DISTRSEL(V1) ; select distribution points
; v1=inventory point da
N %,D,DISTR,DISTRNM,PRCPEXIT,PRCPFLAG,PRCPLINE,PRCPINPT
K ^TMP($J,"PRCPURS3"),DISTRALL
S PRCPINPT=+V1,PRCPLINE="",$P(PRCPLINE,"-",76)="",PRCPLINE="+"_PRCPLINE_"+"
S %=$$ALLDISTR I %=0 Q
I %=1 S DISTRALL=1
F D I $G(PRCPFLAG) Q
. W !
. I $O(^TMP($J,"PRCPURS3","YES",0))]""!($G(DISTRALL)) D
. . W !?2,PRCPLINE,!?2,"| Currently selected ",$S(PRCP("DPTYPE")="S":"recipients:",1:"distribution points:"),?78,"|"
. . I $G(DISTRALL) W !?2,"| << ALL ",$S(PRCP("DPTYPE")="S":"RECIPIENTS",1:"DISTRIBUTION POINTS")," >>",?78,"|"
. . E D
. . . W !?2,"| "
. . . S D=0 F S D=$O(^TMP($J,"PRCPURS3","YES",D)) Q:D']"" S %=$E(^(D),1,20),%=%_$E(" ",$L(%),20) W:$X>70 ?78,"|",!?2,"| " W %," "
. . . W ?78,"|"
. . W !?2,"| You can DE-select one of the above ",$S(PRCP("DPTYPE")="S":"recipients:",1:"distribution points:")," by reselecting it.",?78,"|"
. I $O(^TMP($J,"PRCPURS3","NO",0))]""!('$G(DISTRALL)) D
. . W !?2,PRCPLINE,!?2,"| Currently DE-selected ",$S(PRCP("DPTYPE")="S":"recipients:",1:"distribution points:"),?78,"|"
. . I '$G(DISTRALL) W !?2,"| << ALL ",$S(PRCP("DPTYPE")="S":"RECIPIENTS",1:"DISTRIBUTION POINTS")," >>",?78,"|"
. . E D
. . . W !?2,"| "
. . . S D=0 F S D=$O(^TMP($J,"PRCPURS3","NO",D)) Q:D']"" S %=$E(^(D),1,20),%=%_$E(" ",$L(%),20) W:$X>70 ?78,"|",!?2,"| " W %," "
. . . W ?78,"|"
. . I PRCP("DPTYPE")'="S" W !?2,"| You can RE-select one of the above distribution points by reselecting it.",?78,"|"
. . I PRCP("DPTYPE")="S" W !?2,"| These recipients can be moved to the SELECTED List by reselecting them.",?78,"|"
. W !?2,PRCPLINE
. I PRCP("DPTYPE")'="S" S DISTR=$$TO^PRCPUDPT(PRCPINPT)
. I PRCP("DPTYPE")="S" S DISTR=$$TOWHOM^PRCPRISS(PRCPINPT)
. I DISTR<0 S (PRCPFLAG,PRCPEXIT)=1 Q
. S DISTRNM="" I PRCP("DPTYPE")="S",DISTR'=0 S DISTRNM=DISTR
. I PRCP("DPTYPE")'="S" S DISTRNM=$$INVNAME^PRCPUX1(DISTR)
. I DISTR=0,$O(^TMP($J,"PRCPURS3","YES",0))']"",'$G(DISTRALL) D Q
. . S %=$$ALLDISTR I %=0 S (PRCPFLAG,PRCPEXIT)=1 Q
. . I %=1 S DISTRALL=1
. I DISTR=0 S PRCPFLAG=1 Q
. I $G(DISTRALL),'$D(^TMP($J,"PRCPURS3","NO",DISTR)) K ^TMP($J,"PRCPURS3","YES",DISTR) S ^TMP($J,"PRCPURS3","NO",DISTR)=DISTRNM W !?10,"*** DE-selected !" Q
. I $D(^TMP($J,"PRCPURS3","YES",DISTR)) K ^TMP($J,"PRCPURS3","YES",DISTR) S ^TMP($J,"PRCPURS3","NO",DISTR)=DISTRNM W !?10,"*** DE-selected !" Q
. I $D(^TMP($J,"PRCPURS3","NO",DISTR)) K ^(DISTR) S ^TMP($J,"PRCPURS3","YES",DISTR)=DISTRNM W !?10,"*** RE-selected !" Q
. S ^TMP($J,"PRCPURS3","YES",DISTR)=DISTRNM W !?10,"*** selected !"
I $G(PRCPEXIT) K ^TMP($J,"PRCPURS3"),DISTRALL Q
I $G(DISTRALL) K ^TMP($J,"PRCPURS3","YES")
Q
;
;
ALLDISTR() ; select all distribution points/recipients
; returns 1 for yes, 2 for no, 0 for ^
I PRCP("DPTYPE")'="S" D
. S XP="Do you want to select ALL distribution points"
. S XH="Enter 'YES' to select ALL distr. points, 'NO' to not select all distr. points."
I PRCP("DPTYPE")="S" D
. S XP="Do you want ALL recipients"
. S XH="Enter 'YES' to select ALL recipients, 'NO' to select individual recipients."
Q $$YN^PRCPUYN(1)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPURS3 3537 printed Sep 23, 2025@19:52:25 Page 2
PRCPURS3 ;WISC/RFJ-select distribution points ;24 May 93
V ;;5.1;IFCAP;**1,108**;Oct 20, 2000;Build 10
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 QUIT
+3 ;
+4 ;
DISTRSEL(V1) ; select distribution points
+1 ; v1=inventory point da
+2 NEW %,D,DISTR,DISTRNM,PRCPEXIT,PRCPFLAG,PRCPLINE,PRCPINPT
+3 KILL ^TMP($JOB,"PRCPURS3"),DISTRALL
+4 SET PRCPINPT=+V1
SET PRCPLINE=""
SET $PIECE(PRCPLINE,"-",76)=""
SET PRCPLINE="+"_PRCPLINE_"+"
+5 SET %=$$ALLDISTR
IF %=0
QUIT
+6 IF %=1
SET DISTRALL=1
+7 FOR
Begin DoDot:1
+8 WRITE !
+9 IF $ORDER(^TMP($JOB,"PRCPURS3","YES",0))]""!($GET(DISTRALL))
Begin DoDot:2
+10 WRITE !?2,PRCPLINE,!?2,"| Currently selected ",$SELECT(PRCP("DPTYPE")="S":"recipients:",1:"distribution points:"),?78,"|"
+11 IF $GET(DISTRALL)
WRITE !?2,"| << ALL ",$SELECT(PRCP("DPTYPE")="S":"RECIPIENTS",1:"DISTRIBUTION POINTS")," >>",?78,"|"
+12 IF '$TEST
Begin DoDot:3
+13 WRITE !?2,"| "
+14 SET D=0
FOR
SET D=$ORDER(^TMP($JOB,"PRCPURS3","YES",D))
if D']""
QUIT
SET %=$EXTRACT(^(D),1,20)
SET %=%_$EXTRACT(" ",$LENGTH(%),20)
if $X>70
WRITE ?78,"|",!?2,"| "
WRITE %," "
+15 WRITE ?78,"|"
End DoDot:3
+16 WRITE !?2,"| You can DE-select one of the above ",$SELECT(PRCP("DPTYPE")="S":"recipients:",1:"distribution points:")," by reselecting it.",?78,"|"
End DoDot:2
+17 IF $ORDER(^TMP($JOB,"PRCPURS3","NO",0))]""!('$GET(DISTRALL))
Begin DoDot:2
+18 WRITE !?2,PRCPLINE,!?2,"| Currently DE-selected ",$SELECT(PRCP("DPTYPE")="S":"recipients:",1:"distribution points:"),?78,"|"
+19 IF '$GET(DISTRALL)
WRITE !?2,"| << ALL ",$SELECT(PRCP("DPTYPE")="S":"RECIPIENTS",1:"DISTRIBUTION POINTS")," >>",?78,"|"
+20 IF '$TEST
Begin DoDot:3
+21 WRITE !?2,"| "
+22 SET D=0
FOR
SET D=$ORDER(^TMP($JOB,"PRCPURS3","NO",D))
if D']""
QUIT
SET %=$EXTRACT(^(D),1,20)
SET %=%_$EXTRACT(" ",$LENGTH(%),20)
if $X>70
WRITE ?78,"|",!?2,"| "
WRITE %," "
+23 WRITE ?78,"|"
End DoDot:3
+24 IF PRCP("DPTYPE")'="S"
WRITE !?2,"| You can RE-select one of the above distribution points by reselecting it.",?78,"|"
+25 IF PRCP("DPTYPE")="S"
WRITE !?2,"| These recipients can be moved to the SELECTED List by reselecting them.",?78,"|"
End DoDot:2
+26 WRITE !?2,PRCPLINE
+27 IF PRCP("DPTYPE")'="S"
SET DISTR=$$TO^PRCPUDPT(PRCPINPT)
+28 IF PRCP("DPTYPE")="S"
SET DISTR=$$TOWHOM^PRCPRISS(PRCPINPT)
+29 IF DISTR<0
SET (PRCPFLAG,PRCPEXIT)=1
QUIT
+30 SET DISTRNM=""
IF PRCP("DPTYPE")="S"
IF DISTR'=0
SET DISTRNM=DISTR
+31 IF PRCP("DPTYPE")'="S"
SET DISTRNM=$$INVNAME^PRCPUX1(DISTR)
+32 IF DISTR=0
IF $ORDER(^TMP($JOB,"PRCPURS3","YES",0))']""
IF '$GET(DISTRALL)
Begin DoDot:2
+33 SET %=$$ALLDISTR
IF %=0
SET (PRCPFLAG,PRCPEXIT)=1
QUIT
+34 IF %=1
SET DISTRALL=1
End DoDot:2
QUIT
+35 IF DISTR=0
SET PRCPFLAG=1
QUIT
+36 IF $GET(DISTRALL)
IF '$DATA(^TMP($JOB,"PRCPURS3","NO",DISTR))
KILL ^TMP($JOB,"PRCPURS3","YES",DISTR)
SET ^TMP($JOB,"PRCPURS3","NO",DISTR)=DISTRNM
WRITE !?10,"*** DE-selected !"
QUIT
+37 IF $DATA(^TMP($JOB,"PRCPURS3","YES",DISTR))
KILL ^TMP($JOB,"PRCPURS3","YES",DISTR)
SET ^TMP($JOB,"PRCPURS3","NO",DISTR)=DISTRNM
WRITE !?10,"*** DE-selected !"
QUIT
+38 IF $DATA(^TMP($JOB,"PRCPURS3","NO",DISTR))
KILL ^(DISTR)
SET ^TMP($JOB,"PRCPURS3","YES",DISTR)=DISTRNM
WRITE !?10,"*** RE-selected !"
QUIT
+39 SET ^TMP($JOB,"PRCPURS3","YES",DISTR)=DISTRNM
WRITE !?10,"*** selected !"
End DoDot:1
IF $GET(PRCPFLAG)
QUIT
+40 IF $GET(PRCPEXIT)
KILL ^TMP($JOB,"PRCPURS3"),DISTRALL
QUIT
+41 IF $GET(DISTRALL)
KILL ^TMP($JOB,"PRCPURS3","YES")
+42 QUIT
+43 ;
+44 ;
ALLDISTR() ; select all distribution points/recipients
+1 ; returns 1 for yes, 2 for no, 0 for ^
+2 IF PRCP("DPTYPE")'="S"
Begin DoDot:1
+3 SET XP="Do you want to select ALL distribution points"
+4 SET XH="Enter 'YES' to select ALL distr. points, 'NO' to not select all distr. points."
End DoDot:1
+5 IF PRCP("DPTYPE")="S"
Begin DoDot:1
+6 SET XP="Do you want ALL recipients"
+7 SET XH="Enter 'YES' to select ALL recipients, 'NO' to select individual recipients."
End DoDot:1
+8 QUIT $$YN^PRCPUYN(1)
