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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHLCS 999 printed Oct 16, 2024@18:09:10 Page 2
PRCHLCS ;SF-ISC/TKW-LOG CODE SHEET UTILITY ROUTINES ;9-13-89/2:37 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
EN1 ;SOURCE DEVIATION/SERIAL NO. FIELD, PRCHL500
+1 if '$DATA(PRCHCS("CANC"))
QUIT
+2 IF PRCHCS("CANC")=""
DO CHK
QUIT
+3 IF (X'?4N)!(X'>2000)
WRITE !!,"Must be a number greater than 2000!",!
KILL X
+4 QUIT
+5 ;
SD DO DSPS
WRITE !!,"Select SOURCE DEVIATION CODE: "
READ X:DTIME
IF '$TEST!(X["^")!(X="")
SET X=" "
QUIT
+1 ;
CHK FOR Z=0:0
SET Z=$ORDER(^PRCD(441.4,"B",X,Z))
if 'Z
QUIT
IF $DATA(^PRCD(441.4,+Z,0))
IF $PIECE(^(0),U,2)="S"
QUIT
+1 IF 'Z
DO W1
GOTO SD
+2 WRITE " "_$PIECE(^PRCD(441.4,Z,0),U,3)
+3 SET %=1
WRITE !,"RIGHT OPTION "
DO YN^DICN
if %=0
DO DSPS
if %'=1
GOTO SD
SET X=" "_X
QUIT
+4 ;
DSPS WRITE !!
FOR I=0:0
SET I=$ORDER(^PRCD(441.4,I))
if 'I
QUIT
IF $DATA(^(I,0))
IF $PIECE(^(0),U,2)="S"
WRITE $PIECE(^(0),U,1)_" "_$PIECE(^(0),U,3),!
+1 QUIT
+2 ;
W1 WRITE $CHAR(7),!,"?? INVALID SELECTION",!!
KILL X
+1 QUIT
+2 ;
EN2 ;ONLINE HELP FOR SOURCE DEVIATION/SERIAL NO.
+1 if '$DATA(PRCHCS("CANC"))
QUIT
IF PRCHCS("CANC")=""
DO DSPS
QUIT
+2 WRITE $CHAR(7),!!,"Enter 4 digit Serial Number",!
+3 QUIT
