source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPW23.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 8.1 KB
Line 
1SCRPW23 ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ; 15 Jul 98 02:38PM
2 ;;5.3;Scheduling;**144,474**;AUG 13, 1993;Build 4
3DIRB(SDFL) ;Get default values for range
4 ;Required input: SDFL="F" for first, "L" for last
5 N SDX S SDX=$O(SDPAR("X",SDS2,$S(SDDV:5,1:4),""),$S(SDFL="F":1,1:-1)) Q $S(SDX=""!'SDDV:SDX,1:SDPAR("X",SDS2,5,SDX))
6 ;
7RL ;Prompt for range or list
8 N SDI,SDIRQ X:$L($P(SDACT,T,9)) $P(SDACT,T,9) S SDDV=0 S:$P(SDACT,T,2)="D" SDDV=1,SDPAR("X",SDS2,6)="D"
9 I $P(SDPAR("X",SDS2,2),U)="N" D NULL Q
10 I $P(SDPAR("X",SDS2,2),U)="L" D LST Q
11RNG N SDR1,SDR2 D SUBT^SCRPW50("*** Item Range Selection ***")
12R1 W !!,"Start with:" S SDR1=$$SEL($P(SDACT,T,2),$$DIRB("F")) Q:SDOUT!SDNUL
13 S SDR2=$O(SDPAR("X",SDS2,$S(SDDV:5,1:4),""),-1) I $L(SDR2),$P(SDR1,U,$S(SDDV:1,1:2))]SDR2 F SDI=SDS1,"X" K SDPAR(SDI,SDS2,$S(SDDV:5,1:4),SDR2)
14R2 W !!,"End with:" S SDR2=$$SEL($P(SDACT,T,2),$$DIRB("L")) Q:SDOUT!SDNUL
15 I '$$RCOL() W !!,$C(7),"End value must collate after start value!" G R2
16 F SDX="SDR1","SDR2" S SDPAR("X",SDS2,4,$P(@SDX,U,2),$P(@SDX,U))=""
17 F SDX="SDR1","SDR2" S SDPAR("X",SDS2,5,$P(@SDX,U))=$P(@SDX,U,2)
18 Q
19 ;
20RCOL() ;Determine range collation validity
21 ;Output: 1=valid, 0=invalid
22 I $P(SDR1,U,2)=+$P(SDR1,U,2),$P(SDR2,U,2)=+$P(SDR2,U,2) Q SDR1'>SDR2
23 I SDDV Q $P(SDR1,U)'>$P(SDR2,U)
24 Q $P(SDR1,U,2)']$P(SDR2,U,2)
25 ;
26NULL ;Set list for null value
27 S SDPAR("X",SDS2,4,"~~~NONE~~~","~~~NONE~~~")="",SDPAR("X",SDS2,5,"~~~NONE~~~")="~~~NONE~~~" Q
28 ;
29LST I $D(SDPAR("X",SDS2,4)) D LST1
30 D SUBT^SCRPW50("*** Item List Selection ***") W !
31 F I=1:1:$P(SDACT,T,6) S SDX=$$SEL($P(SDACT,T,2)) Q:SDOUT!SDNUL D LST0
32 Q
33 ;
34LST0 I $D(SDPAR("X",SDS2,5,$P(SDX,U))) Q:$$LSD()
35 S SDPAR("X",SDS2,5,$P(SDX,U))=$P(SDX,U,2),SDPAR("X",SDS2,4,$P(SDX,U,2),$P(SDX,U))=""
36 Q
37 ;
38LSD() N DIR W !!,$C(7),$P(SDX,U,2)," is already selected." S DIR(0)="Y",DIR("A")="Do you want to delete it",DIR("B")="NO" D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q 0
39 I Y D W !," ...deleted." Q 1
40 .F SDI=SDS1,"X" K SDPAR(SDI,SDS2,5,$P(SDX,U)),SDPAR(SDI,SDS2,4,$P(SDX,U,2),$P(SDX,U))
41 .Q
42 Q 0
43 ;
44LST1 ;List existing item selections
45 N SDOUT,SDL,SDX S SDOUT=0,SDL=1,SDX="" W !,"Items currently selected:"
46 F S SDX=$O(SDPAR("X",SDS2,4,SDX)) Q:SDX=""!SDOUT S SDL=SDL+1 W !?5,SDX D:SDL>15 WAIT^SCRPW22
47 Q
48 ;
49SEL(SDTYP,SDIRB) ;Select items for list or range
50 ;Required input: SDTYP=type of data (D, P, F, N, T, C, PP, S)
51 ;Optional input: SDIRB=value for default prompt
52 N SDX S SDX="" D @SDTYP Q SDX
53 ;
54D ;Get date values
55 N DIR M DIR=SDIRQ S DIR(0)=$P(SDACT,T,4),DIR("A")="Select "_$P(SDACT,T) S:$L($G(SDIRB)) DIR("B")=SDIRB D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
56 I '$L(Y) S SDNUL=1 Q
57 S SDX=Y X ^DD("DD") S SDX=SDX_U_Y X:$L($P(SDACT,T,8)) $P(SDACT,T,8) Q
58 ;
59P ;Get pointer values ;SD*5.3*474 added PSCRN to screen certain status types
60 N DIC M DIC=SDIRQ S DIC=$P(SDACT,T,3),DIC(0)="AEMQ",DIC("S")=$P(SDACT,T,4) K:'$L(DIC("S")) DIC("S") D:DIC="^SD(409.63," PSCRN D ^DIC I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
61 I Y'>0 S SDNUL=1 Q
62 S SDX=Y X:$L($P(SDACT,T,8)) $P(SDACT,T,8) Q
63 ;
64PSCRN ;screen out the 4 cancellation type status' SD*5.3*474
65 S DIC("S")="I $P(^(0),U,2)'=""C"",$P(^(0),U,2)'=""CA"",$P(^(0),U,2)'=""PC"",$P(^(0),U,2)'=""PCA"""
66 Q
67 ;
68F ;Get field values
69 N DIR M DIR=SDIRQ S DIR(0)=$P(SDACT,T,3) S:$L($G(SDIRB)) DIR("B")=SDIRB D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
70 I '$D(DIR("B")),X="" S SDNUL=1 Q
71 S SDX=Y_U_$G(Y(0)) X:$L($P(SDACT,T,8)) $P(SDACT,T,8) Q
72 ;
73N ;Get number value
74 N DIR M DIR=SDIRQ S DIR(0)=$P(SDACT,T,4),DIR("A")="Select "_$P(SDACT,T) S:$L($G(SDIRB)) DIR("B")=SDIRB D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
75 I Y'?1.N S SDNUL=1 Q
76 S SDX=Y_U_Y X:$L($P(SDACT,T,8)) $P(SDACT,T,8) Q
77 ;
78T ;Get text value
79 N DIR M DIR=SDIRQ S DIR(0)=$P(SDACT,T,4),DIR("A")="Select "_$P(SDACT,T) S:$L($G(SDIRB)) DIR("B")=SDIRB D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
80 I '$L(Y) S SDNUL=1 Q
81 S SDX=Y_U_Y X:$L($P(SDACT,T,8)) $P(SDACT,T,8) Q
82 ;
83C ;Get computed value
84 D @($P(SDACT,T,4)) X:$L($P(SDACT,T,8)) $P(SDACT,T,8) Q
85 ;
86PP ;Get pointer value from file multiple
87 N DIC M DIC=SDIRQ S DIC=$P($P(SDACT,T,3),";"),DIC(0)="AEMQ",DIC("B")=$P($G(SDIRB),";") K:'$L(DIC("B")) DIC("B") D ^DIC I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
88 I Y<1 S SDNUL=1 Q
89 S SDX=Y,DIC=DIC_+SDX_$P($P(SDACT,T,3),";",2),DIC("B")=$P($G(SDIRB),";",2) K:'$L(DIC("B")) DIC("B") D ^DIC I $D(DTOUT)!$D(DUOUT) S SDX="",SDOUT=1 Q
90 I Y<1 S SDX="",SDNUL=1 Q
91 S SDX=+SDX_";"_+Y_U_$P(SDX,U,2)_" / "_$P(Y,U,2) X:$L($P(SDACT,T,8)) $P(SDACT,T,8) Q
92 ;
93S ;Get set-of-codes value
94 N DIR M DIR=SDIRQ X $P(SDACT,T,3) S DIR("A")="Select "_$P(SDACT,T) S:$L($G(SDIRB)) DIR("B")=SDIRB D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
95 I '$L(Y) S SDNUL=1 Q
96 S SDX=Y_U_Y(0) X:$L($P(SDACT,T,8)) $P(SDACT,T,8) Q
97 ;
98VCP(SDX) ;Validate Stop Code credit pair
99 ;Required input: SDX=6 digit numeric value
100 ;Output: 1=valid credit pair, 0=invalid credit pair
101 G:SDX'?6N VCPQ G:'$D(^DIC(40.7,"C",$E(SDX,1,3))) VCPQ G:'$D(^DIC(40.7,"C",$E(SDX,4,6)))&($E(SDX,4,6)'="000") VCPQ
102 Q 1
103 ;
104VCPQ W $C(7)," ??",!,"This response must be a 6 digit numeric value",!,"that represents two valid stop codes!" Q 0
105 ;
106PLIST ;Print category list
107 N ZTSAVE D EN^XUTMDEVQ("PLST^SCRPW23","CATEGORY LIST",.ZTSAVE) Q
108PLST ;Print category list
109 D:'$D(^TMP("SCRPW",$J,"SEL")) BLD^SCRPW21
110 S I=0 F S I=$O(^TMP("SCRPW",$J,"SEL",1,I)) Q:'I S X1=$O(^TMP("SCRPW",$J,"SEL",1,I,"")) W !!,$P(^TMP("SCRPW",$J,"SEL",1,I,X1),"~") D PLST1
111 K I,II,X1,X2,^TMP("SCRPW",$J) Q
112 ;
113PLST1 S II=0 F S II=$O(^TMP("SCRPW",$J,"SEL",2,X1,II)) Q:'II S X2=$O(^TMP("SCRPW",$J,"SEL",2,X1,II,"")) W !?4,$P(^TMP("SCRPW",$J,"SEL",2,X1,II,X2),"~")
114 Q
115 ;
116DISP0 ;Return to full screen scrolling
117 Q:$E(IOST)'="C"
118 D ENS^%ZISS S SDRM=^%ZOSF("RM"),SDXY=^%ZOSF("XY"),(IOTM,IOBM)=0 W $$XY(IOSTBM,1),@IOF N DX,DY,X S (DX,DY)=0 X SDXY S X=IOM X SDRM Q
119 ;
120DISP(SDTOP,SDBOT) ;Create centered scrolling region
121 ;Required input: SDTOP=text to center at top of screen
122 ;Required input: SDBOT(n)=numbered array of text to display at bottom of screen
123 N X D DISP0 S X=0 X SDRM W $$XY(IORVON) F I=1:1:(78-$L(SDTOP)\2) W "-"
124 W " ",SDTOP," " F W "-" Q:$X>79
125 W $$XY(IORVOFF) S IOTM=3 W $$XY(IOSTBM,1) S (C,I)="" F S I=$O(SDBOT(I)) Q:I="" S C=C+1
126 F W ! Q:$Y>(IOSL-C)
127 S II=$O(SDBOT("")) Q:II="" W $$XY(IORVON) F I=1:1:(78-$L(SDBOT(II))\2) W "-"
128 W " ",SDBOT(II)," " F W "-" Q:$X>79
129 W $$XY(IORVOFF) F S II=$O(SDBOT(II)) Q:II="" W !,$E(SDBOT(II),1,80)
130 S IOBM=(IOSL-C-1) W $$XY(IOSTBM,1) Q
131 ;
132XY(X,SDI) ;Maintain $X, $Y
133 ;Required input: X=screen handling variable to write
134 ;Optional input: SDI=1 (to specify the use of indirection)
135 N DX,DY S DX=$X,DY=$Y
136 I $G(SDI) W @X X SDXY Q ""
137 W X X SDXY Q ""
138 ;
139DIR(DIR,SDLEV,SDEXE,SDS,SDO,SDPFL,SDA) ;Ask questions!
140 ;Required input: DIR array (pass by reference)
141 ;Required input: SDLEV=level to build DIR(0) for large sets
142 ;Optional input: SDEXE=code to execute prior to ^DIR
143 ;Optional input: SDS=subscript lookup value for level 2 (required for level 2)
144 ;Optional input: SDO="O" to indicate input is optional
145 ;Optional input: SDPFL=print field level (1,2) for print field prompts
146 ;Optional input: SDA=1 to force single item selection prompt
147 X:$L($G(SDEXE)) SDEXE I '$D(DIR(0)) D @("DIR"_SDLEV)
148 I '$G(SDA),$E(DIR(0))="S",$L(DIR(0),":")=2 Q $P($P(DIR(0),U,2),":")_U_$P(DIR(0),":",2)
149 D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q ""
150 I X="" S SDNUL=1 Q ""
151 Q Y_U_$S($L($G(Y(0))):Y(0),1:Y)
152 ;
153DIR1 N X,I,II S X="",I=0 F S I=$O(^TMP("SCRPW",$J,"SEL",1,I)) Q:'I S II="" F S II=$O(^TMP("SCRPW",$J,"SEL",1,I,II)) Q:II="" S:$$PFL1() X=X_";"_II_":"_$P(^TMP("SCRPW",$J,"SEL",1,I,II),T)
154 S DIR(0)="S"_$G(SDO)_"^"_$E(X,2,245) Q
155 ;
156DIR2 N X,I,II S X="",I=0 F S I=$O(^TMP("SCRPW",$J,"SEL",2,SDS,I)) Q:'I S II="" F S II=$O(^TMP("SCRPW",$J,"SEL",2,SDS,I,II)) Q:II="" S:$$PFL2() X=X_";"_II_":"_$P(^TMP("SCRPW",$J,"SEL",2,SDS,I,II),T)
157 S DIR(0)="S"_$G(SDO)_"^"_$E(X,2,245) Q
158 ;
159PFL1() ;Print field level 1 evaluator
160 Q:'$G(SDPFL) 1
161 Q $P(^TMP("SCRPW",$J,"SEL",1,I,II),T,2)>(SDPFL-1)
162 ;
163PFL2() ;Print field level 2 evaluator
164 Q:'$G(SDPFL) 1
165 Q $P(^TMP("SCRPW",$J,"SEL",2,SDS,I,II),T,2)>(SDPFL-1)
166 ;
167DIRB1(S1,S2,SDEF) ;Set DIR("B")
168 ;Required input: S1, S2=subscript values
169 ;Optional input: SDEF=default value
170 S DIR("B")=$S($D(SDPAR(S1,S2)):$P(SDPAR(S1,S2),U,2),1:$G(SDEF))
171 K:'$L(DIR("B")) DIR("B") Q
Note: See TracBrowser for help on using the repository browser.