28 lines
972 B
Mathematica
28 lines
972 B
Mathematica
PRCHLCS ;SF-ISC/TKW-LOG CODE SHEET UTILITY ROUTINES ;9-13-89/2:37 PM
|
|
V ;;5.1;IFCAP;;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
;
|
|
EN1 ;SOURCE DEVIATION/SERIAL NO. FIELD, PRCHL500
|
|
Q:'$D(PRCHCS("CANC"))
|
|
I PRCHCS("CANC")="" D CHK Q
|
|
I (X'?4N)!(X'>2000) W !!,"Must be a number greater than 2000!",! K X
|
|
Q
|
|
;
|
|
SD D DSPS W !!,"Select SOURCE DEVIATION CODE: " R X:DTIME I '$T!(X["^")!(X="") S X=" " Q
|
|
;
|
|
CHK F Z=0:0 S Z=$O(^PRCD(441.4,"B",X,Z)) Q:'Z I $D(^PRCD(441.4,+Z,0)),$P(^(0),U,2)="S" Q
|
|
I 'Z D W1 G SD
|
|
W " "_$P(^PRCD(441.4,Z,0),U,3)
|
|
S %=1 W !,"RIGHT OPTION " D YN^DICN D:%=0 DSPS G:%'=1 SD S X=" "_X Q
|
|
;
|
|
DSPS W !! F I=0:0 S I=$O(^PRCD(441.4,I)) Q:'I I $D(^(I,0)),$P(^(0),U,2)="S" W $P(^(0),U,1)_" "_$P(^(0),U,3),!
|
|
Q
|
|
;
|
|
W1 W $C(7),!,"?? INVALID SELECTION",!! K X
|
|
Q
|
|
;
|
|
EN2 ;ONLINE HELP FOR SOURCE DEVIATION/SERIAL NO.
|
|
Q:'$D(PRCHCS("CANC")) I PRCHCS("CANC")="" D DSPS Q
|
|
W $C(7),!!,"Enter 4 digit Serial Number",!
|
|
Q
|