- 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 Feb 18, 2025@23:34:48 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