- 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 Mar 13, 2025@21:21:08 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)
