source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPURS3.m@ 1697

Last change on this file since 1697 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.4 KB
RevLine 
[613]1PRCPURS3 ;WISC/RFJ-select distribution points ;24 May 93
2V ;;5.1;IFCAP;**1,108**;Oct 20, 2000;Build 10
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 Q
5 ;
6 ;
7DISTRSEL(V1) ; select distribution points
8 ; v1=inventory point da
9 N %,D,DISTR,DISTRNM,PRCPEXIT,PRCPFLAG,PRCPLINE,PRCPINPT
10 K ^TMP($J,"PRCPURS3"),DISTRALL
11 S PRCPINPT=+V1,PRCPLINE="",$P(PRCPLINE,"-",76)="",PRCPLINE="+"_PRCPLINE_"+"
12 S %=$$ALLDISTR I %=0 Q
13 I %=1 S DISTRALL=1
14 F D I $G(PRCPFLAG) Q
15 . W !
16 . I $O(^TMP($J,"PRCPURS3","YES",0))]""!($G(DISTRALL)) D
17 . . W !?2,PRCPLINE,!?2,"| Currently selected ",$S(PRCP("DPTYPE")="S":"recipients:",1:"distribution points:"),?78,"|"
18 . . I $G(DISTRALL) W !?2,"| << ALL ",$S(PRCP("DPTYPE")="S":"RECIPIENTS",1:"DISTRIBUTION POINTS")," >>",?78,"|"
19 . . E D
20 . . . W !?2,"| "
21 . . . 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 %," "
22 . . . W ?78,"|"
23 . . W !?2,"| You can DE-select one of the above ",$S(PRCP("DPTYPE")="S":"recipients:",1:"distribution points:")," by reselecting it.",?78,"|"
24 . I $O(^TMP($J,"PRCPURS3","NO",0))]""!('$G(DISTRALL)) D
25 . . W !?2,PRCPLINE,!?2,"| Currently DE-selected ",$S(PRCP("DPTYPE")="S":"recipients:",1:"distribution points:"),?78,"|"
26 . . I '$G(DISTRALL) W !?2,"| << ALL ",$S(PRCP("DPTYPE")="S":"RECIPIENTS",1:"DISTRIBUTION POINTS")," >>",?78,"|"
27 . . E D
28 . . . W !?2,"| "
29 . . . 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 %," "
30 . . . W ?78,"|"
31 . . I PRCP("DPTYPE")'="S" W !?2,"| You can RE-select one of the above distribution points by reselecting it.",?78,"|"
32 . . I PRCP("DPTYPE")="S" W !?2,"| These recipients can be moved to the SELECTED List by reselecting them.",?78,"|"
33 . W !?2,PRCPLINE
34 . I PRCP("DPTYPE")'="S" S DISTR=$$TO^PRCPUDPT(PRCPINPT)
35 . I PRCP("DPTYPE")="S" S DISTR=$$TOWHOM^PRCPRISS(PRCPINPT)
36 . I DISTR<0 S (PRCPFLAG,PRCPEXIT)=1 Q
37 . S DISTRNM="" I PRCP("DPTYPE")="S",DISTR'=0 S DISTRNM=DISTR
38 . I PRCP("DPTYPE")'="S" S DISTRNM=$$INVNAME^PRCPUX1(DISTR)
39 . I DISTR=0,$O(^TMP($J,"PRCPURS3","YES",0))']"",'$G(DISTRALL) D Q
40 . . S %=$$ALLDISTR I %=0 S (PRCPFLAG,PRCPEXIT)=1 Q
41 . . I %=1 S DISTRALL=1
42 . I DISTR=0 S PRCPFLAG=1 Q
43 . 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
44 . 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
45 . I $D(^TMP($J,"PRCPURS3","NO",DISTR)) K ^(DISTR) S ^TMP($J,"PRCPURS3","YES",DISTR)=DISTRNM W !?10,"*** RE-selected !" Q
46 . S ^TMP($J,"PRCPURS3","YES",DISTR)=DISTRNM W !?10,"*** selected !"
47 I $G(PRCPEXIT) K ^TMP($J,"PRCPURS3"),DISTRALL Q
48 I $G(DISTRALL) K ^TMP($J,"PRCPURS3","YES")
49 Q
50 ;
51 ;
52ALLDISTR() ; select all distribution points/recipients
53 ; returns 1 for yes, 2 for no, 0 for ^
54 I PRCP("DPTYPE")'="S" D
55 . S XP="Do you want to select ALL distribution points"
56 . S XH="Enter 'YES' to select ALL distr. points, 'NO' to not select all distr. points."
57 I PRCP("DPTYPE")="S" D
58 . S XP="Do you want ALL recipients"
59 . S XH="Enter 'YES' to select ALL recipients, 'NO' to select individual recipients."
60 Q $$YN^PRCPUYN(1)
Note: See TracBrowser for help on using the repository browser.